Trailing-Edge
-
PDP-10 Archives
-
-
There are no other files named in the archive.
C COMMON/PTABLE/NPCNT
COMMON/OVERLY/NNNN
COMMON/BCDIN/INTAPE,KTYPE,FORMAT,LNTAPE,LUNIT,NUNIT,REWIND,XHEIT,
1 NAMP
COMMON/CALB/CAL(32)
DOUBLE PRECISION NAMCHN
COMMON/CHANEL/NAMCHN(32),NVU,NCODE,NPULS,NNV(32),IPRNT
COMMON/BRI/FILE(2),LONG,BCODE,HCODE,LENGTH,BPULSE,HPULSE,EXPNO,
1PSTART,PEND,TSTART,TEND,IDAY,IHR,IMIN,ISEC,SAMPRT,ISKIP
COMMON/XDATA/ICODE,IPOINT
COMMON/TABLE/ISCANC,INCODE,ISCANP,INPULS,FILID(2),NREC
COMMON/PTABLE/NPCNT,NPREC,NPLOC
LOGICAL IPRNT
INTEGER BCODE,HCODE,BPULSE,HPULSE,EXPNO,PSTART,PEND
INTEGER BCODEA,HCODEA,BPULSA,HPULSA
C INITIALIZATION
DIMENSION Q(10000),NAMPRO(9),A(19),NREGM(9),NREGV(9),TEMP(16),
1 ITEMP(16),F(9),TITLE(18,9),FORMAT(18,9),LUNIT(3,9),XAMFRQ(9)
DIMENSION NPLOC(400,2)
EQUIVALENCE (RBLANK,BLANK),(NBLANK,BLANK)
DATA KDIV/-1/
DATA NTOT/10000/
REAL LABL,NAMCH,NAME
INTEGER BRI,BCD,BIN
DATA NAMPRO/9*' '/,PROB/'PROB'/,NAMCH/'NAMC'/,TITL/'TITL'/,
1 PARAM/'PARA'/,POSITN/'POSI'/,FINISH/'FINI'/,BRI/'BRI '/
DATA NPROB/0/,JNAMCH/0/,NBLANK/' '/,NREG/1/
DOUBLE PRECISION NULL,NCADE,NSTIM,RBLANK
DATA NULL/'NULL '/,NCADE/'CODE '/,NSTIM/'STIM '/,
1RBLANK/' '/
DATA NPULSA,NPULSB/0,0/
DATA NAME/'NAME'/,FORM/'FORM'/
DATA IDP/1/,IDG/5/,INPTYP/'BRI '/,TPULS/1.0/,NOPULS/1/,NALYS/1/,
1 BLANK/' '/
SAMPRT=256.
CALL USAGEB('BMDX93')
DATA IO/-1/,IOB/-1/,NOVFMT/1/
DATA FMAX/9999./,XCODE/ 0.0/,XPULSE/ 0.0/
DATA CALIB/'CALI'/,BCD/'BCD '/,BIN/'BIN '/,YES/'YES '/
FILE(1)=BLANK
FILE(2)=BLANK
ISKIP=2
LABL=NBLANK
NNNN=0
INVALD=0
NVU=0
NCODE=0
KTYPE=0
HPULSE=0
INTAPE=5
LONG=30
LENGT1=1
LENGT2=2
BPULSE=0
DO 8 J=1,9
XAMFRQ(J)=0.
DO 8 I=1,3
8 LUNIT(I,J)=0
DO 9 I=1,32
9 CAL(I)=1.0
BCODE=0
NUNIT=0
HCODE=100
NPCNT=0
INTAPE=5
C NNV(I)=1 IF CHAN IS USED, =0 IF NOT USED
C NVU NO OF CHANNELS USED
C NV NO OF CHANNELS ON TAPE
C NAMPRO NAMES OF PROBLEMS
C PROB ALPHA PROB
C NAMCH ALPHA NAME
C TITLE ALPHA TITL
C FORMAT ARRAY WHICH CONTAINS VARIABLE INPUT FORMAT
C PARAM ALPHA PARA
C REWIND ''NO''=INPUT TAPE IS NOT TO BE REWOUND FOR THIS PROBLEM
C POSITN ALPHA POSI
C NPROB NUMBER OF PROBLEMS BEING EXECUTED
C JNAMCH ZERO IF NO NAMCH CARD EXISTS, ONE OTHERWISE
C A STORAGE AREA TO SAVE PROBLEM CARDS
C FINISH ALPHA FINI
C NBLANK ALPHA BLANK
C NAMP NAME OF PROBLEM BEING READ IN
C LUNIT ARRAY WHICH KEEPS TRACK OF SCAN POSITIONING AND NO. OF PULSES
C PROBLM
C NUNIT COUNTER FOR THE NUMBER OF DIFFERENT UNITS USED.
C IDP DECIMATION FOR PRINTING
C IDG DECIMATION FOR GRAPH
C INTAPE LOGICAL INPUT TAPE IF NOT BRI INPUT
C INPTYP TYPE OF INPUT
C LNTAPE CONTAINS LAST INPUT UNIT READ IN OFF PARAM CARD.
C TPULSE TIME FROM PULSE TO END OF ANALYSIS(TIME BASE)
C NOPULS NUMBER OF PULSE CHANNELS
C IPULSA FIRST PULSE CHANNEL
C IPULSB SECOND PULSE CHANNEL
C NALYS TYPE OF ANALYSIS, 1 IF SINGLE CLICK, 2 IF PAIRED CLICK
C SAMPRT SAMPLING RATE
C NVUA NUMBER OF GOOD CHANNELS
C NVA TOTAL NUMBER OF CHANNELS
C NDEL 1 IF END OF PROBLEM, 0 IF OTHERWISE
C JANAL PROBLEM CURRENTLY BEING ANALYSED
C NREG NEXT REGION IN Q TO BE USED
C NREGM WHERE THE MEANS BEGIN FOR EACH PROBLEM
C NREGV WHERE THE VARIANCES BEGIN FOR EACH PROBLEM
C TEMP PARAMETERS FOR POSIT
C ITEMP PARAMETERS FOR POSIT
C IERROR ERROR RETURN FROM POSIT
C NSCAN NUMBER OF SCANS IN TIME BASE
C MPULSE 0 TO ANALYSE ON FIRST CHANNEL,1 TO ANALYSE ON SECOND CHANNEL
C NTEMPM INDICES FOR STORING DATA
C F NUMBER OF POINTS OR OBSERVATIONS(PULSES) IN SUMMATION
C F NUMBER OF POINTS IN A SUMMATION
C KTYPE 0=BRI DIGITIZED INPUT, 1=BCD INPUT, 2=BINARY INPUT
C NOVFMT NUMBER OF INPUT VARIABLE FORMAT CARDS
C IPRNT .TRUE.=STANDARD POSITIONING PRINTOUT,.FALSE.=DEBUG PRINTOUT
C GENERAL READ STATEMENT
10 IF(LABL.EQ.FINISH)GO TO 80
READ (5,1010,END=300) LABL,A
1010 FORMAT (20A4)
1013 REWIND 1
WRITE (1,1010) LABL,A
REWIND 1
C CALL USEBUF
IF(LABL.EQ. FINISH) GO TO 80
C IF (LABL.EQ.NAMCH) GO TO 60
IF(LABL.EQ. PROB ) GO TO 20
IF (INVALD .EQ.1) GO TO 10
IF (NPROB.EQ.0) WRITE (6,1015) LABL,A
1015 FORMAT (' FIRST PROBLEM, A CARD OTHER THAN A PROBLEM CARD=',20A4)
IF (LABL.EQ.NAMCH.OR.LABL.EQ.NAME) GO TO 60
IF(LABL.EQ.TITL)GO TO 70
IF(LABL.EQ. PARAM ) GO TO 30
IF(LABL.EQ. POSITN) GO TO 30
IF (LABL.EQ.FORM) GO TO 95
IF(LABL.EQ.CALIB)GO TO 85
C IF LABEL DOES NOT MATCH,WE GO TO NEXT PROBLEM
WRITE (6,1011) LABL,A
1011 FORMAT (' THE FOLLOWING CARD WAS IMPROPERLY PUNCHED'//1X,20A4/
1 '0THE NEXT CARDS LISTED WERE NOT EXECUTED'/'0WE WILL CONTINUE AT
2 THE NEXT PROBLEM')
INVALD =1
C NPROB=0
C DO 15 I=1,9
C 15 NAMPRO(I)=NBLANK
C READ (5,1010) LABL,A
GO TO 10
20 NPROB=NPROB+1
INVALD =0
C READ PROBLEM CARD
READ (1,1020,END=310) LABL,NAMPRO(NPROB),SAMPRA,NVUA,NVA,TPULSA,
1 NOPULA,IPULAA,IPULBA,NALYSA,IDPA,IDGA,INPTYA,MAXF,IOA,IOBA
2,KDIVA,OTRACE
1020 FORMAT (2A4,F5.0,2I2,F5.0,6I2,A3,I5,3I2,A3)
IF(MAXF.GT.0)FMAX=MAXF-.5
XAMFRQ(NPROB)=FMAX
IF (NPROB.NE.1) GO TO 2020
LENGTH=LENGT1
IF (INPTYA.EQ.NBLANK.OR.INPTYA.EQ.INPTYP) LENGTH=LENGT2
2020 IF (KDIVA.NE.0) KDIV=KDIVA
IF(SAMPRA.GT.0)SAMPRT=SAMPRA
IF(NVUA.GT.0)NVU=NVUA
IF(NVA.GT.0)NV=NVA
IF(TPULSA.GT.0)TPULS=TPULSA
IF(NOPULA.GT.0)NOPULS=NOPULA
IPRNT=.FALSE.
IF (OTRACE.EQ.YES) IPRNT=.TRUE.
IF (IPULAA.GT.0)NPULSA=IPULAA
IF(IPULBA.GT.0)NPULSB=IPULBA
IF (IOA.NE.0) IO=IOA
IF (IOBA.NE.0) IOB=IOBA
IF(NALYSA.GT.0)NALYS=NALYSA
1022 FORMAT (' WARNING--COLS. 58-62 ON PROB CARD ARE ZERO AND INPUT DAT
1A FROM CARDS, THIS MAY CAUSE TROUBLE'/' WILL READ UNTIL END OF FIL
2E')
IF(IDPA.GT.0)IDP=IDPA
IF(IDGA.GT.0)IDG=IDGA
IF (INPTYA.NE.NBLANK) INPTYP=INPTYA
KTYPE=0
IF (INPTYP.EQ.BCD) KTYPE=1
IF (INPTYP.EQ.BIN) KTYPE=2
IF(NOPULS.EQ.2.AND.NPULSB.LE.0)GO TO 90
IF(NALYS.EQ.2.AND.NOPULS.NE.2)GO TO 90
IA=NREG
NSCAN=TPULS*SAMPRT
NREGM(NPROB)=NREG
NREGV(NPROB)=NREG+NSCAN*NVU
NREG=NREG+2*NSCAN*NVU
IF(NALYS.EQ.2.AND.NREG+NSCAN*NVU.GT.NTOT)GO TO 22
IF(NREG.LT.NTOT)GO TO 123
22 CONTINUE
WRITE(6,1023)NAMPRO(NPROB),NREG,NTOT
1023 FORMAT('1THE SPACE REQUIRED FOR PROBLEM',A6,' IS',I7,' LOCATIONS
1, BUT ONLY',I7, ' LOCATIONS ARE AVAILABLE'/'0REDUCE PROBLEM SIZE
2 '/'0THIS PROBLEM WILL BE SKIPPED'/)
NAMPRO(NPROB)=NBLANK
NPROB=NPROB-1
NREG=IA
123 CONTINUE
F(NPROB)=0.0
DO 23 I=IA,NREG
23 Q(I)=0.0
DO 24 I=1,18
24 TITLE(I,NPROB)=BLANK
GO TO 10
30 CONTINUE
CALF=1.0
IF (NCODE.EQ.0) GO TO 87
IF (CAL(NCODE).EQ.0.)CAL(NCODE)=1.0
CALF=CAL(NCODE)
87 DO 86 I=1,16
IF (CAL(I).EQ.0.) CAL(I)=CALF
86 CONTINUE
C READ PARAM OR POSITION CARD
READ (1,1030)LABL,LONGA,BCODEA,XCODEA,LENGTA,BPULSA,XPULSA,EXPNO,
1PSTART,PEND,TSTART,TEND,IDAY,IHR,IMIN,ISEC,NAMP,NDEL,INTAPA,NVFMTA
2,REWIND,NCSTOP
1030 FORMAT(A4,2X,I3,I5,F5.0,2I3,F5.0,3I3,2F7.0,I3,3I2,A4,I1,2I2,A3,I5)
LBEGIN=PSTART
IF (KTYPE.NE.0) GO TO 430
HCODEA=XCODEA
HPULSA=XPULSA
430 IF (NVFMTA.GT.0) NOVFMT=NVFMTA
LNTAPE=INTAPE
IF (INTAPA.GT.0) INTAPE=INTAPA
IF (INTAPE.EQ.5.AND.NCSTOP.EQ.0.AND.KTYPE.EQ.1) WRITE (6,1022)
AMAXF=PEND-PSTART+1.
IF (MAXF.EQ.0) FMAX=AMAXF-0.5
IF(NPROB.EQ.0)GO TO 33
DO 32 I=1,NPROB
IF(NAMP.NE.NAMPRO(I)) GO TO 32
JANAL=I
GO TO 31
32 CONTINUE
33 WRITE(6,1033)NAMP
1033 FORMAT('1PARAM CARD FOUND WITH FOLLOWING NAME' A6,/
1 '0THE CARD WILL BE IGNORED')
GO TO 10
31 CONTINUE
IF (XAMFRQ(JANAL).GT.FMAX) FMAX=XAMFRQ(JANAL)
IF (IPRNT) WRITE (6,2134)
2134 FORMAT (1H ,10(1H*),104HNOTE--COMPLETE POSITIONING AND TRACING PRI
1NTOUT REQUESTED (USE THIS SPARINGLY TO AVOID EXCESSIVE OUTPUT),
2 10(1H*))
IF(LONGA.NE.0)LONG=LONGA
IF(BCODEA.NE.0)BCODE=BCODEA
IF (XCODEA.NE.0) XCODE=XCODEA
IF(HCODEA.NE.0)HCODE=HCODEA
IF (XPULSA.NE.0) XPULSE=XPULSA
IF(LENGTA.NE.0)LENGTH=LENGTA
IF(BPULSA.NE.0)BPULSE=BPULSA
IF(HPULSA.NE.0)HPULSE=HPULSA
IF (KTYPE.EQ.0) WRITE (6,1031) LONG,BCODE,HCODE,LENGTH,BPULSE,
1 HPULSE,EXPNO,PSTART,PEND,TSTART,TEND,IDAY,IHR,IMIN,ISEC,NAMP,NDEL
1031 FORMAT
X(11X,'LONG = ',I3,' BCODE = ',I5,' HCODE = ',I5,' LENGTH = ',I3
X/11X,'BPULSE = ',I3,' HPULSE = ',I5,' EXPNO = ',I3
X/11X,'PSTART = ',I3,' PEND = ',I3,' TSTART = ',F7.3,' TEND = '
X,F7.3/11X,'IDAY = ',I3,' IHR = ',I2,' IMIN = ',I2,' ISEC = ' ,
XI2,' PROBLEM 'A4,' END 'I2)
NCNT=0
ISCANA=0
NSTOP=TEND*SAMPRT
NPULS=NPULSA
XHEIT=XCODE
IF(FMAX.LT.F(JANAL))GO TO 43
C IF(PSTART.GT.0.AND.TSTART.EQ.0)PSTART=1
IF (KTYPE.NE.0) GO TO 35
IF(PSTART.GT.0.AND.TSTART.EQ.0.)GO TO 35
IF (KTYPE.EQ.0) CALL PICKLS
IF (IERROR.GT.0)STOP
133 ISCANA=NNNN
TSTART=0.0
PSTART=NPCNT+1
35 CONTINUE
IF (LBEGIN.EQ.PSTART) GO TO 2435
LNTAPE=INTAPE
IF ((NNNN+1).GT.NCSTOP.AND.INTAPE.EQ.5.AND.NCSTOP.GT.0) GO TO 43
IF (NALYS.EQ.1.AND.PEND.GT.0.AND.NPCNT.GE.PEND) GO TO 43
REWIND=0.0
2435 IREG=NREG
IF (KTYPE.EQ.0) CALL PICKLS
IF (KTYPE.NE.0) CALL FPULSE (NV,PSTART,TSTART,SAMPRT,NPULS,LENGTH,
1 IPRNT,NERROR)
C IF (IERROR.GT.0) STOP
IF (NERROR) 43,236,93
236 IF (LABL.EQ.POSITN) GO TO 10
IF (NPCNT.EQ.LBEGIN) WRITE (6,2236) LBEGIN
2236 FORMAT (1H ,10(1H*),'BEGINNING ANALYSIS ON PULSE NUMBER',I3,10(1H*
1))
IF (NVU.EQ.0)GO TO 91
C TSTART=0
IF (ISCANA.EQ.0) ISCANA=NNNN
NSTOPB=NSTOP-NNNN+ISCANA
IF (TEND.GT.0.0.AND.NSTOPB.LE.0.AND.KTYPE.EQ.0) GO TO 43
IF ((NNNN+NSCAN).GT.NCSTOP.AND.NCSTOP.GT.0) GO TO 43
NTEMPM=NREGM(JANAL)
NTEMPV=NREGV(JANAL)
F(JANAL)=F(JANAL)+1.0
DO 140 II=1,NSCAN
GO TO (237,238),KTYPE
CALL PICKLS
IF(IFSTOP.GT.0)GO TO 42
GO TO 250
237 READ (INTAPE,FORMAT,END=42) (TEMP(I),I=1,NV)
IF(TEMP(1).EQ.-1.)GO TO 42
NNNN=NNNN+1
GO TO 240
238 READ (INTAPE,END=42) (TEMP(I),I=1,NV)
NNNN=NNNN+1
240 I=1
DO 245 K=1,NV
IF (NNV(K).NE.1) GO TO 245
TEMP(I)=TEMP(K)
I=I+1
245 CONTINUE
C IF (NVU.NE.I-1) PRINT 246, I,NVU
C 246 FORMAT (' LOGICA MISTAKE IN CALUULATING NO. OF VARS. USED, NVU=',
C 1 I5,' I=',I5)
250 IF (NALYS.EQ.1) GO TO 37
IF (NPULSB.EQ.NPULS) GO TO 36
DO 134 I=1,NVU
Q(IREG)=TEMP(I)
134 IREG=IREG+1
GO TO 140
36 DO 135 I=1,NVU
TEMP(I)=TEMP(I)-Q(IREG)
135 IREG=IREG+1
37 DO 39 J=1,NVU
D=TEMP(J) - Q(NTEMPM)
Q(NTEMPM)= Q (NTEMPM)+ D/F(JANAL)
Q(NTEMPV)= Q (NTEMPV)+ D*(TEMP(J)-Q(NTEMPM))
NTEMPM=NTEMPM+1
NTEMPV=NTEMPV+1
39 CONTINUE
140 CONTINUE
IF (NOPULS.EQ.1) GO TO 40
IF(NPULSA.EQ.NPULS) GO TO 38
NPULS=NPULSA
XHEIT=XCODE
GO TO 40
38 NPULS=NPULSB
XHEIT=XPULSE
IF(NALYS.EQ.2)F(JANAL)=F(JANAL)-1.0
40 CONTINUE
150 PSTART=PSTART+1
IF(PSTART.GT.NPCNT)GO TO 160
IF(NREC.GT.NPLOC(PSTART,1))GO TO 150
IF(IPOINT.GT.NPLOC(PSTART,2))GO TO 150
160 CONTINUE
IF(FMAX.LT.F(JANAL))GO TO 43
C IF (PEND.GT.0.AND.PEND.GE.NPCNT) GO TO 43
GO TO 35
42 F(JANAL)=F(JANAL)-1.0
43 IF (INTAPE.NE.5.OR.NNNN.GE.NCSTOP) GO TO 44
NX=NNNN+1
IF(NSTOP.NE.0)GO TO 2042
2046 READ(5,FORMAT,ERR=44,END=44)
GO TO 2046
2042 DO 2044 I=NX,NCSTOP
2044 READ (5,FORMAT)
44 IF (NDEL.EQ.0) GO TO 10
WRITE (6,2043) PEND
2043 FORMAT (1H ,10(1H*),'END ANALYSIS BEFORE PULSE NUMBER',I3,10(1H*))
WRITE (6,999)
999 FORMAT('1',20X,'BMDX93..........TIME-LOCKED AVERAGING PROGRAM'//
1 25X,'(WITH INPUT TO BMD05D)'//
2 25X,'HEALTH SCIENCES CONPUTING FACILITY'//
325X,'REVISED JUNE 24, 1968')
WRITE (6,1032) (TITLE(I,JANAL),I=1,18)
1032 FORMAT (/T10,'THE TITLE IS'/T20,18A4//)
IF (MAXF.EQ.0) MAXF=FMAX+0.5
WRITE(6,998)(I,NAMCHN(I),CAL(I),I=1,NV)
998 FORMAT('0',T10,'CHAN NO',T20,'NAME',T30,'CALIBRATION FACTOR'/
1(T15,I2,T20,A8,T32,F7.2))
WRITE(6,1034)NAMPRO(JANAL),SAMPRT,NV,NVU,TPULS,NOPULS,NPULSA,NPUL
1SB,IO,IOB,NALYS,IDP,IDG,INPTYP,MAXF,KDIV
1034 FORMAT(//
1 T10,'NAME OF PROBLEM'T50,A4/T10,'SAMPLING RATE'T47,F7.2/ T1
10,'NUMBER OF VARIABLES'T50,I4/T10,'NUMBER OF VARIABLES ANALYZED'T5
A0
2,I4/T10,'TIME BASE'T48,F6.3/T10,'NUMBER OF PULSE CHANNELS'T50,I4/T
320,'VARIABLES'I4,' AND'I4/T10,'OUTPUT UNIT FOR 05D CARDS'T50,I4/T
410,'OUTPUT UNIT FOR DATA'T50,I4/T10,'METHOD OF ANALYSIS'T50,I4/T10
5,'DECIMATION FOR PRINTER'T50,I4/T10,'DECIMATION FOR PLOT'T50,I4/T1
60,'TYPE OF INPUT',T51,A3/T10,'MAX. NUMBER OF CASES IN ANY AVERAGE'
7,T49,I5/T10,'NO. OF GROUPS THE AVERAGES SPLIT INTO',T50,I4)
IF (KTYPE.NE.0) WRITE (6,1133) INTAPE,NVFMTA
1133 FORMAT (T10,'LOGICAL UNIT FOR INPUT DATA',T50,I4/T10,'NUMBER OF IN
1PUT VARIABLE FORMAT CARDS',T50,I4)
IF (KTYPE.NE.0.AND.INTAPE.EQ.5) WRITE (6,1134) NCSTOP
1134 FORMAT (T10,'NUMBER OF CARDS INPUT THIS PROBLEM', T50,I4)
CALL OUTPUT (Q(NREGM(JANAL)),Q(NREGV(JANAL)),NSCAN,NVU,IDP,IO,
1 F(JANAL),NAMPRO(JANAL),IDG,SAMPRT,IOB,TITLE(1,JANAL),KDIV)
C WE DELETE THE SPACE ASSIGNED TO THE PROBLEM
NPROB=NPROB-1
NREGD=2*(NREGV(JANAL)-NREGM(JANAL))
NREG=NREG-NREGD
IF (JANAL.GT.NPROB) GO TO 10
IA=NREGM(JANAL)-1
DO 45 I=1,NREGD
45 Q(IA+I)=Q(I+IA+NREGD)
DO 46 I=JANAL,NPROB
F(I)=F(I+1)
NAMPRO(I)=NAMPRO(I+1)
NREGM(I)=NREGM(I+1)-NREGD
46 NREGV(I)=NREGV(I+1)-NREGD
DO 47 I=JANAL,NPROB
DO 47 J=1,18
47 TITLE(J,I)=TITLE(J,I+1)
GO TO 10
60 JNAMCH=1
IF (LABL.EQ.NAME) GO TO 61
C READ NAMCHN CARD
READ (1,1060) (NAMCHN(I),I=1,NV)
1060 FORMAT (6X,16A4)
GO TO 1064
61 READ (1,1062) (NAMCHN(I),I=1,NV)
1062 FORMAT (6X,8A8)
1064 DO 62 I=1,32
62 NNV(I)=0
NCODE=0
J=0
DO 63 I=1,NV
NNV(I)=1
J=J+1
IF(NAMCHN(I).NE.RBLANK.AND.NAMCHN(I).NE.NULL.AND.NAMCHN(I).NE.
1 NSTIM.AND.NAMCHN(I).NE.NCADE)GO TO 63
J=J-1
NNV(I)=0
IF(NAMCHN(I).EQ.NCADE)NCODE=I
63 CONTINUE
NVU=MIN0(NVU,J)
GO TO 10
300 WRITE (6,301) LABL, A
301 FORMAT (' END OF FILE ENCOUNTERED WHILE READING CONTROL CARDS, THE
1 LAST CARD READ WAS'/1X,20A4)
STOP
70 CONTINUE
C READ TITLE CARD
READ (1,1070,END=310) LABL,NAMP,(A(I),I=1,18)
1070 FORMAT (20A4)
DO 72 I=1,NPROB
IF(NAMP.NE.NAMPRO(I)) GO TO 72
DO 71 J=1,18
71 TITLE(J,I)=A(J)
GO TO 10
310 WRITE (6,311) LABL
311 FORMAT (' END OF FILE ENCOUNTERED WHILE READING UNIT 1 FOR FORMAT
1CONVERSION, LAST LABEL READ WAS',A5)
STOP
72 CONTINUE
WRITE(6,1072) NAMP,A
1072 FORMAT('1THE FOLLOWING TITLES CARD DID NOT CORRESPOND TO ANY
1KNOWN PROBLEM'/'0NAME=',A6, ' TITLE IS',2X,18A4,/' THE CARD
2WILL BE IGNORED')
GO TO 10
80 CONTINUE
C IF FINISH CARD IS READ
IF(NPROB.GT.0)GO TO 82
IF(INPTYP.EQ.BRI) CALL PICKLS
WRITE (6,1080)
1080 FORMAT('1FINISH CARD READ,PROBLEM TERMINATED' /1X)
WRITE (IO,1090)
1090 FORMAT('FINISH',T80,'5')
STOP
82 JANAL=NPROB
GO TO 44
85 READ (1,1085) (CAL(I),I=1,NV)
1085 FORMAT (6X,16F4.0)
GO TO 10
90 WRITE(6,1091)NAMPRO(NPROB)
1091 FORMAT('1',10X,'THE NUMBER OF PULSE CHANNELS FOR PROBLEM' A6,
1 ' IS INCORRECT'/20X,'THIS PROBLEM WILL BE SKIPPED')
NPROB=NPROB -1
GO TO10
91 WRITE(6,1092)
1092 FORMAT('1THE NUMBER OF CHANNELS TO BE ANALYSED IS ZERO,'/
1 '0CHECK THAT A CORRECT NAMC CARD PRECEDES THE PARA CARD OR THAT
1NUMBER OF CHANNELS TO BE ANALYSED WAS SPECIFIED ON PROB CARD'/
2 '0THIS JOB IS TERMINATED')
93 IF (INPTYP.EQ.BRI) CALL PICKLS
STOP
95 CONTINUE
C READ VARIABLE FORMAT CARD(S)
I=1
98 READ (1,1070,END=310) LABL,(FORMAT(J,I),J=1,19)
READ (5,1010,END=300) LABL,A
IF (LABL.NE.FORM) GO TO 1013
I=I+1
GO TO 98
END
SUBROUTINE PICKLS
WRITE(6,1)
1 FORMAT(' THIS IS THE SUBROUTINE THAT WAS MISSING FROM THE ' /
1'ORIGINAL LISTING. I THINK IT IS THE SAME AS THE SUBROUTINE '/
2'POSIT FROM BMDX92,WHICH IS MERELY AN ERROR ROUTINE.')
RETURN
END
SUBROUTINE OUTPUT (XMEAN,VAR,N,NVAR,IDP,IO,F,NAME,IDG,SAMPRT,IOB,
1 TITLE,KDIV)
DOUBLE PRECISION NAMCHN
COMMON/CHANEL/NAMCHN(32),NVU,NCODE,NPULS,NNV(32)
COMMON/CALB/CAL(32)
DIMENSION TITLE(14)
DIMENSION XMEAN(NVAR,N),VAR(NVAR,N),VAL(32),VALV(32),VALVA(32),
1VALVB(32)
DIMENSION XX(10)
IF(IDP.EQ.0)IDP=1
IF (IOB.LE.0) GO TO 2005
WRITE (6,2010) IOB
DO 2001 I=1,N
DO 2002 K=1,NVAR
2002 VAL(K)=SQRT(VAR(K,I))
WRITE (IOB,2000) (XMEAN(J,I),VAL(J),J=1,NVAR)
2000 FORMAT (30A4)
2001 CONTINUE
2005 CONTINUE
DP=IDP
SAMPRA=SAMPRT/DP
2010 FORMAT ( //' REQUEST FOR OUTPUT OF MEANS AND STANDARD DEVIATIONS
1 TO BE WRITTEN ON LOGICAL UNIT',I3/' THIS DATA IS WRITTEN AS MEAN
2AND ST. DEV. FOR EACH CHANNEL ANALYZED FOR EACH SCAN, USING (20A4)
3 FORMAT')
IDIFF=(N+9)/10
IF (N.LE.10*IDP) IDIFF=IDP
DO 4 I=1,10
4 XX(I)=(I-1)*IDIFF/SAMPRT
LL=0
DO 11 M=1,NVAR
5 LL=LL+1
IF(NNV (LL).EQ.0)GO TO 5
WRITE(6,1000)NAME
1000 FORMAT('1',T20,'PRINTOUT OF MEANS FOR PROBLEM'2X,A4)
WRITE(6,1001)(TITLE(I),I=1,14)
1001 FORMAT(T20,'TITLE---'20A4 )
WRITE(6,1002)LL,NAMCHN(LL),F,IDP
1002 FORMAT(1T20,'VARIABLE',T49,I2,1X,A6/T20,'NUMBER OF SCANS PER AVERA
1GE',T52,F6.0/T20,'DECIMATION FOR PRINTER',T57,I2)
WRITE(6,998)(XX(I),I=1,10)
998 FORMAT(/' TIME',T13,10F12.5/)
DPA=DP*CAL(LL)
DO 10 I=1,IDIFF,IDP
L=0
DO 9J=I,N,IDIFF
L=L+1
VAL(L)=0.0
DO 8 K=1,IDP
8 VAL(L)=VAL(L)+XMEAN (M,J+K-1)
9 VAL(L)=VAL(L)/DPA
X=(I-1)/(SAMPRA*IDP)
WRITE(6,1009)X,(VAL(II),II=1,L)
1009 FORMAT(11F12.5)
10 CONTINUE
11 CONTINUE
IF(F.LT.1.5)RETURN
LL=0
DO 21 M=1,NVAR
15 LL=LL+1
IF(NNV(LL).EQ.0)GO TO 15
WRITE(6,1020)NAME
1020 FORMAT('1', T20,'PRINTOUT OF STANDARD DEVIATIONS OF AN OBSERVATIO
1N FOR PROBLEM' 2X,A4)
WRITE(6,1001)(TITLE(I),I=1,14)
WRITE(6,1002)LL,NAMCHN(LL),F,IDP
WRITE(6,998)(XX(I),I=1,10)
DPA=(CAL(LL)**2)*DP*(F-1.0)
DO 30 I=1,IDIFF,IDP
L=0
DO 29 J=I,N,IDIFF
L=L+1
VAL(L)=0.0
DO 28 K=1,IDP
28 VAL(L)=VAL(L)+VAR(M,J+K-1)
VAL(L)=VAL(L)/DPA
29 VAL(L)=SQRT(VAL(L))
X=(I-1)/(SAMPRA*IDP)
WRITE(6,1009)X,(VAL(II),II=1,L)
30 CONTINUE
21 CONTINUE
31 IOUT=5
IF (IO.LE.0) GO TO 70
NV=3*NVAR+1
NS=N/IDG
WRITE(IO,1040)NAME,NV,NS,NVAR,IOUT
1040 FORMAT('PROBLM' A4,T13,I3,I5,I3,T69,I2,' 1')
1041 FORMAT('(16A4)',T80,'5')
WRITE(IO,1041)
DG=IDG
FF=(F-1.0)*DG*F
IF(FF.LT.1.0)FF=1000000.
NN=NS*IDG
DO 50 I=1,NN,IDG
LLL=0
DO 48 J=1,NVAR
45 LLL=LLL+1
IF (NNV(LLL).EQ.0)GO TO 45
FFA=(CAL(LLL)**2)*FF
DGA=DG*CAL(LLL)
VAL(J)=0
VALV(J)=0.0
DO 49 L=1,IDG
VAL(J)=VAL(J)+XMEAN(J,I+L-1)
49 VALV(J)=VALV(J)+VAR(J,I+L-1)
VAL(J)=VAL(J)/DGA
VALV(J)=SQRT(VALV(J)/FFA)
VALVA(J)=VAL(J)-VALV(J)
48 VALVB(J)=VAL(J)+VALV(J)
X=(I-1)/SAMPRT
WRITE (IO,1049) X,(VALVA(J),VAL(J),VALVB(J),J=1,NVAR)
1049 FORMAT(16A4)
50 CONTINUE
L=0
DO 60 M=1,NVAR
59 L=L+1
IF(NNV(L).EQ.0)GO TO 59
MA=3*M-1
MB=MA+1
MC=MB+1
WRITE(IO,1050)
1050 FORMAT('SELECT2003001-1' T80,'3')
WRITE (IO,1053) (TITLE(I),I=1,18)
1053 FORMAT (2X,18A4,T80,'2')
WRITE(IO,1051) L,NAMCHN(L)
1051 FORMAT(T16,'VARIABLE NUMBER' I5,5X,'NAME' A6,T80,'2')
WRITE (IO,1052) MA,MB,MC
1052 FORMAT('CRSVAR' I3,'-',T16,I3,'*',T25,I3,'+',T80,'3')
60 CONTINUE
DIMENSION VARDIV(30),VARSTD(30),XMDIV(30),XMSTD(30)
70 IF(KDIV.LE.0)GO TO 79
NDIV=N/KDIV
WRITE(6,1030)KDIV,NDIV
1030 FORMAT('1 THE FOLLOWING ARE SUMMARY STATISTICS BASED ON THE AVER
1AGES.'/5X,'THE AVERAGES WERE SPLIT INTO' I5,2X,'GROUPS WITH ABOUT'
2 I5,2X,'VALUES IN EACH GROUP')
L=0
DO 75 I=1,NVAR
DO 71 J=1,KDIV
XMDIV(J)=0.0
XMSTD(J)=0.
VARDIV(J)=0.
VARSTD(J)=0.
71 CONTINUE
72 L=L+1
IF(NNV(L).LE.0)GO TO 72
DO 74 J=1,KDIV
KA=(J-1)*N/KDIV+1
KB=J*N/KDIV
DO 73 K=KA,KB
XMDIV(J)=XMEAN(I,K)+XMDIV(J)
XMSTD(J)=XMSTD(J)+XMEAN(I,K)*XMEAN(I,K)
XY=ALOG(VAR(I,K))
VARDIV(J)=VARDIV(J)+XY
VARSTD(J)=VARSTD(J)+XY*XY
73 CONTINUE
XY=KB-KA+1
XMDIV(J)=XMDIV(J)/(XY*CAL(L))
XMSTD(J)=SQRT(ABS((XMSTD(J)/CAL(L)**2-XY*XMDIV(J)**2)/(XY-1)))
VARSTD(J)=EXP(.5*(SQRT(ABS((VARSTD(J)-VARDIV(J)**2 /XY)/(XY-1)))))
VARDIV(J)=EXP(.5*VARDIV(J)/XY)/(CAL(L)*SQRT(F-1.))
74 CONTINUE
WRITE(6,1074) L,NAMCHN(L)
WRITE(6,1075)(XMDIV(J),J=1,KDIV )
WRITE(6,1076)(XMSTD(J),J=1,KDIV)
WRITE(6,1077)(VARDIV(J),J=1,KDIV)
WRITE(6,1078)(VARSTD(J),J=1,KDIV)
1074 FORMAT ('0SUMMARY FOR CHANNEL',I4,2X,A8)
1075 FORMAT(' PARTIAL MEANS',(T30,10F10.3))
1076 FORMAT (' STD DEV OF EACH MEAN',(T30,10F10.3))
1077 FORMAT(' PARTIAL STD DEVS',(T30,10F10.3))
1078 FORMAT(' SCALE FOR STD DEV',(T30,10F10.3))
75 CONTINUE
WRITE(6,1071)
1071 FORMAT('1')
79 CONTINUE
RETURN
END
SUBROUTINE FPULSE(NV,PSTART,TSTART,SAMPRT,NPULS,LENGTH,IPRNT,IERRO
1R)
COMMON/BCDIN/INTAPE,KTYPE,FORMAT,LNTAPE,LUNIT,NUNIT,REWIND,HCODE,
1 NAMP
COMMON/PTABLE/NPCNT
COMMON/OVERLY/NCASE
INTEGER PSTART
DIMENSION DATA(16,20),FORMAT(18,9),LUNIT(3,9)
DATA YES/'YES '/
LOGICAL IPRNT
IERROR=0
IF (KTYPE.NE.1.AND.KTYPE.NE.2) GO TO 225
IF (NUNIT.EQ.0) GO TO 2100
IF (INTAPE.EQ.1) WRITE (6,1001) INTAPE
IF (LNTAPE.EQ.INTAPE) GO TO 213
DO 2098 K=1,NUNIT
IF (LNTAPE.EQ.LUNIT(1,K)) GO TO 2070
2098 CONTINUE
NUNIT=NUNIT+1
LUNIT(2,NUNIT)=NCASE
LUNIT(1,NUNIT)=LNTAPE
LUNIT(3,NUNIT)=NPCNT
GO TO 2060
2070 LUNIT(2,K)=NCASE
LUNIT(3,K)=NPCNT
2060 DO 2065 I=1,NUNIT
IF (INTAPE.EQ.LUNIT(1,I)) GO TO 2050
2065 CONTINUE
NUNIT=NUNIT+1
LUNIT(1,NUNIT)=INTAPE
NCASE=0
NPCNT=0
GO TO 213
2050 NCASE=LUNIT(2,I)
NPCNT=LUNIT(3,I)
GO TO 213
2100 LUNIT(1,1)=INTAPE
NUNIT=NUNIT+1
213 IF (PSTART.LT.NPCNT) GO TO 200
IF (REWIND.EQ.YES) GO TO 201
35 IF (NCASE.LE.0) WRITE(6,1) NAMP,INTAPE
1 FORMAT (1H1//T40,'HEALTH SCIENCES COMPUTING FACILITY'/T40,34(1H-)
1///T20,'POSITIONING FOR INPUT FOR PROBLEM NAMED',A5,' ON UNIT',
1 I5/T60,'----'////)
IF (TSTART.GE.0.) GO TO 15
WRITE (6,12) TSTART
12 FORMAT (' A NEGATIVE VALUE OF TSTART=',F12.2,' THIS IS NOT ALLOWED
1IN BCD/BINARY POSITIONING'/' RECOMMENDATION--POSITION ON AN EARLIE
2R PULSE AND USE A POSITIVE TSTART'/' FOR THE TIME BEING, TSTART WI
3LL BE SET EQUAL TO ZERO AND THE JOB WILL CONTINUE')
TSTART=0.0
15 CONTINUE
IF (IPRNT) WRITE (6,20) NPULS,HCODE,LENGTH,PSTART,TSTART
20 FORMAT (' POSITIONING ON CHANNEL',I5,' USING A CUTOFF POINT OF',F1
12.3,' AND A MINIMUM LENGTH OF',I4,' SCANS.'/' POSITION ON PULSE',
2 I3,', TSTART=',F12.3)
IF (PSTART.EQ.NPCNT.AND.TSTART.GT.0.) GO TO 50
5 I=1
11 IF (KTYPE.EQ.1) READ (INTAPE,FORMAT,ERR=130,END=150) (DATA(J,I),
1J=1,NV)
IF (KTYPE.EQ.2) READ (INTAPE,ERR=130,END=150) (DATA(J,I),J=1,NV)
NCASE=NCASE+1
C DETERMINE IF SCAN DOES NOT CONFORM TO PULSE SPECIFICATIONS
IF(HCODE.GE.0.AND.DATA(NPULS,I).LE.HCODE)GO TO 5
IF (HCODE.LT.0.AND.DATA(NPULS,I).GT.HCODE) GO TO 5
IF (I.GE.LENGTH) GO TO 10
I=I+1
GO TO 11
10 NPCNT=NPCNT+1
SEC=FLOAT(NCASE)/SAMPRT
WRITE (6,25) NPCNT,NCASE,SEC
25 FORMAT (' PULSE',I5,', LEADING EDGE DETECTED AFTER READING',I6,
1 ' SCANS(',F12.3,' SECONDS)')
IF (NPCNT.LT.PSTART) GO TO 5
50 NSKIP=TSTART*SAMPRT-1
IF (NSKIP.LE.0) RETURN
IF (KTYPE.EQ.1) GO TO 60
DO 55 I=1,NSKIP
NCASE=NCASE+1
55 READ (INTAPE,ERR=130,END=150)
RETURN
60 DO 65 I=1,NSKIP
NCASE=NCASE+1
65 READ (INTAPE,FORMAT,ERR=130,END=150)
RETURN
130 PRINT 131,INTAPE,NPCNT,NCASE
131 FORMAT (' AN I/O ERROR DETECTED ON INPUT TAPE ON LOGICAL UNIT',
1 I4,' DURING OR AFTER DETECTION ON PULSE',I3,'. ',F12.2,' SCANS I
1NTO TAPE'/' JOB WILL BE TERMINATED')
140 IERROR=1
RETURN
150 PRINT 151,INTAPE,NPCNT,NCASE
151 FORMAT (' END OF FILE DETECTED ON INPUT TAPE ON LOGICAL UNIT',I4,
1' DURING OR AFTER DETECTION ON PULSE',I3,'. ',F12.2,' SCANS INTO
2TAPE'//' JOB WILL CONTINUE')
IERROR=-1
RETURN
200 CONTINUE
C STARTING PULSE IS LESS THEN CURRENT POSITION ON THAT UNIT
IF (PSTART.LT.0) GO TO 205
201 IF (INTAPE.EQ.5) GO TO 210
IF (REWIND.NE.YES) WRITE (6,202) INTAPE,NPCNT,PSTART
202 FORMAT (' INCONGRUENCY FOUND--FOR INPUT TAPE ON UNIT',I3, /
1' COLS. 72-73 SPECIFY NO REWIND ON PARAM CARD, YET PSTART IS LESS
2THAN THE CURRENT POSITION ON TAPE'/10X,'CURRENT PULSE COUNT=',I4,
33X,'PSTART=',I4/10X,'THIS IS A WARNING, THE TAPE WILL BE REWOUND')
1001 FORMAT (' WARNING--THE INPUT TAPE IS ON UNIT',I3,' WHICH IS THE UN
1IT USED BY THIS PROGRAM FOR CONVERSION')
NCASE=0
NPCNT=00
REWIND INTAPE
GO TO 35
205 WRITE (6,206) PSTART
206 FORMAT (' ERROR PSTART=',I5,' A NEGATIVE PSTART IS NOT ACCEPTABLE,
1 JOB TERMINATED')
GO TO 140
210 CONTINUE
NPCNT=0
NCASE=0
GO TO 35
225 WRITE (6,226) KTYPE
226 FORMAT (' ERROR IN CALL TO FPULSE, KTYPE=',I3/' JOB IS TERMINATED'
1)
GO TO 140
END