C PROGRAM MCTIVO COMMON ARRAY(411),DUMI(90),MANU,BLNO COMMON/DC/Q(477),V(477),P(477) COMMON/BD/PHEAD(15) DIMENSION NAME(2),NONEUP(20),NONEDO(20),DYCO(411) 1 ,PROUT(15),DIF(80),DYCOE(90) EQUIVALENCE (ARRAY(1),DYCO(1)),(DUMI(1),DYCOE(1)) REAL NAME,INGAS INTEGER ENDA,ARRAY,BLNO,CASE WRITE(4,3) 3 FORMAT(1H ,'ENTER MANEUVER ID,NO OF BLOCKS,SAMPLING RATE'/ 1 ' SCALE FACTORS FOR V,Q, AND P.'/' 2 (I2,I2,I4,3F6.2)') READ (4,2) MANU,NBL,ISR,SFV,SFQ,SFP C SFP IS +, BUT SFQ AND SFV ARE -!!! 2 FORMAT(I2,I2,I4,3F6.2) 6 FORMAT(2I6,2A6,F6.0,A6) 7 FORMAT(30X,'EXPERIMENT DATE',5X,I6/30X,'DATE ANALYZED' 1 ,7X,I6/30X,'SUBJECT',13X,2A6/30X,'DEPTH',15X,F6.0/30X, 2 'INERT GAS',11X,A6/30X,'MANEUVER',12X,I4////) WRITE(4,407) 407 FORMAT(1H ,'ENTER EXPERIMENT DATE, DATE ANALYZED 1 ,SUBJECT NAME,'/' DEPTH AND THE INERT GAS.'/ 2 ' (2I6,2A6,F6.0,A6)') READ (4,6) IDEA,IDER,NAME(1),NAME(2),DEPTH,INGAS WRITE(3,7) IDEA,IDER,NAME(1),NAME(2),DEPTH,INGAS,MANU MAXNO=1365 NMAX=476 LITDY=80 SR=ISR HV=1./SR PLINE=0. ENDA=255 IEND=NMAX IQ=0 DO 95 IBA=1,NBL BLNO=IBA CALL TRANS IF(IBA.NE.NBL) GO TO 110 DO 121 IT=1,255 IF(ARRAY(IT).NE.0) GO TO 121 IA=IT+1 IZ=IT+9 IF(IZ.GT.255) IZ=255 DO 122 ITT=IA,IZ IF(ARRAY(ITT).NE.0) GO TO 121 122 CONTINUE ENDA=IT-1 GO TO 110 121 CONTINUE 110 DO 95 MA=2,ENDA,3 IQ=IQ+1 IF(IQ.LE.MAXNO) GO TO 95 WRITE(4,97) IQ GO TO 99 95 Q(IQ)=-ARRAY(MA) C DO 901 JQ=1,IQ C 901 WRITE(3,902) JQ,Q(JQ) C 902 FORMAT(1H ,'Q',2X,I4,5X,I6) WRITE(4,903) IQ 903 FORMAT(1H ,'IQ=',I4) IIN=0 IDO=0 NOM=0 IST=1 30 IF(Q(IST+1).GT.Q(IST)) GO TO 31 IF(Q(IST+1).LT.Q(IST)) GO TO 32 WRITE(4,409) 409 FORMAT(1H ,'THE 2 Q S ARE EQUAL.') IST=IST+1 GO TO 30 31 DO 34 KQ=IST,IQ IMP=KQ IF(Q(KQ+1).EQ.Q(KQ)) GO TO 34 IF(Q(KQ+1).LT.Q(KQ)) GO TO 37 IF((Q(KQ).LE.0.).AND.(Q(KQ+1).GT.0.)) GO TO 36 GO TO 34 36 IIN=IIN+1 NONEUP(IIN)=KQ WRITE(3,236) KQ,IIN,Q(KQ) 236 FORMAT(1H ,I5,5X,'ZERO CROSS UP',3X,I4,5X,I6) 34 CONTINUE IF(IMP.GE.IQ) GO TO 40 37 IST=IMP+1 32 DO 35 LQ=IST,IQ IMQ=LQ IF(Q(LQ+1).EQ.Q(LQ)) GO TO 35 IF(Q(LQ+1).GT.Q(LQ)) GO TO 38 IF((Q(LQ).GE.0.).AND.(Q(LQ+1).LT.0.)) GO TO 336 GO TO 35 336 IDO=IDO+1 WRITE (3,237) LQ,IDO,Q(LQ) 237 FORMAT(1H ,I5,5X,'ZERO CROSS DOWN',3X,I4,5X,I6) NONEDO(IDO)=LQ 35 CONTINUE IF(IMQ.GE.IQ) GO TO 40 38 IST=IMQ+1 GO TO 31 904 FORMAT(1H ,'NUMBER OF DOWN ZERO CROSSINGS=',I6/1H , 1 'NUMBER OF UP ZERO CROSSINGS=',I6) 40 IF(NONEDO(1).GT.NONEUP(1)) GO TO 42 DO 41 MQ=1,IDO-1 41 NONEDO(MQ)=NONEDO(MQ+1) IDO=IDO-1 GO TO 40 42 IF(NONEDO(IDO).LT.NONEUP(IIN)) GO TO 20 IDO=IDO-1 GO TO 42 20 WRITE(4,904) IDO,IIN C DO 929 JPM=1,IDO C WRITE(3,928) JPM,NONEUP(JPM) C 929 WRITE(3,927) JPM,NONEDO(JPM) 927 FORMAT(1H ,'NONEDO(',I3,')=',I5) 928 FORMAT(1H ,'NONEUP(',I3,')=',I5) C WRITE(3,928) IIN,NONEUP(IIN) ICASE=1 INB=NONEUP(1)*3-2 DO 176 IC=1,16 INC=IC IF(INB.LE.255) GO TO 177 176 INB=INB-255 177 NBA=INC ISTART=INB DO 601 JY=2,IIN NPON=NONEUP(JY)-NONEUP(1)+1 IF(NPON.LE.NMAX) GO TO 601 UPTO=NONEUP(JY-1) IEND=UPTO-NONEUP(1)+1 INBB=UPTO*3-2 IENDB=IEND LULL=JY-1 NOSET=LULL-1 C WRITE(4,945) NOSET,ICASE,LULL 945 FORMAT(1H ,'NOSET=',I4,10X,'ICASE=',I4,10X,'LULL=',I4) GO TO 602 601 CONTINUE 602 DO 614 IM=2,IDO NONEDO(IM)=NONEDO(IM)-NONEUP(1)+1 614 NONEUP(IM)=NONEUP(IM)-NONEUP(1)+1 NONEUP(IIN)=NONEUP(IIN)-NONEUP(1)+1 NONEDO(1)=NONEDO(1)-NONEUP(1)+1 NONEUP(1)=1 25 IAM=1 C DO 829 JPP=1,IDO C WRITE(3,928) JPP,NONEUP(JPP) C 829 WRITE(3,927) JPP,NONEDO(JPP) C WRITE(3,928) IIN,NONEUP(IIN) WRITE (4,221) NBA,ISTART,IEND 221 FORMAT(1H ,'NBA ',I2,3X,'ISTART ',I4,3X,'IEND ',I4) C WRITE(4,904) IDO,IIN IV=0 IQ=0 IP=0 DO 90 IBL=NBA,NBL BLNO=IBL IF(IBL.NE.NBA) ISTART=1 CALL TRANS DO 90 M=ISTART,255 GO TO (11,12,13),IAM 11 IV=IV+1 IF(IV.GT.IEND) GO TO 50 IF(IV.LE.NMAX) GO TO 911 WRITE(4,97) IV GO TO 99 911 V(IV)=ARRAY(M) IAM=2 GO TO 90 12 IQ=IQ+1 Q(IQ)=ARRAY(M) IAM=3 GO TO 90 13 IP=IP+1 P(IP)=ARRAY(M) IAM=1 90 CONTINUE 50 DO 33 JM=1,IEND V(JM)=V(JM)*SFV Q(JM)=Q(JM)*SFQ P(JM)=P(JM)*SFP C WRITE(3,218) JM,V(JM),Q(JM),P(JM) 218 FORMAT(1H ,I4,3X,'V ',F7.3,2X,'Q ',F7.2,2X, 1 'P ',F7.2) 33 CONTINUE DO 45 IS=1,NOSET KS=IS+NOM C WRITE(4,945) NOSET,ICASE,LULL IALF=NONEUP(IS) IZED=NONEUP(IS+1) IMED=NONEDO(IS) WRITE(4,947) IALF,IMED,IZED 947 FORMAT(1H ,'IALF=',I4,5X,'IMED=',I4,5X,'IZED=',I4) ICUR=IZED-IALF+1 TIDVOL=V(IMED)-V(IALF) IMAD=IMED-IALF+1 IZAD=IZED-IMED+1 PERIOD=HV*(IMAD+IZAD-1) PERIOI=HV*IMAD PERIOE=HV*IZAD PMIN=P(IALF) PMINBK=PMIN CASE=0 PMAX=P(IMED) PMAXBK=PMAX IF(IMAD.LE.LITDY) GO TO 44 WRITE(4,144) IS,ICASE,IMAD 144 FORMAT(1H1,'HELP. CURVE',I2,' OF BATCH',I2, 1 ' IS LARGER THAN DIMENSIONED. NAMELY:',I5/) GO TO 99 44 DO 46 IT=IALF,IMED ITT=IT-IALF+1 C WRITE (3,942) V(IALF),V(IMED) 942 FORMAT(1H ,'V(IALF)=',F7.3,5X,'V(IMED)=',F7.3) CALL LINE(DYCO(ITT),IT,IALF,IMED) IF(P(IT).GE.PMIN) GO TO 46 PALX=PMINBK PMINBK=PMIN PMIN=P(IT) PMINM1=P(IT-1) PMINP1=P(IT+1) DELTAA=PMIN-PMINM1 DELTAB=PMINP1-PMIN IF(DELTAA.LT.0.) DELTAA=-DELTAA IF(DELTAB.LT.0.) DELTAB=-DELTAB IF((DELTAA.LT.30.).OR.(DELTAB.LT.30.)) GO TO 46 P(IT)=(P(IT-1)+P(IT+1))/2. WRITE(4,822) PMIN,P(IT) 822 FORMAT(1H ,'SPIKE. OLD VALUE OF P=',F7.2,3X,'NEW AVER 1 AGED VALUE=',F7.2) IF(P(IT).LT.PMINBK) GO TO 46 PMIN=PMINBK PMINBK=PALX 46 CONTINUE IF(IZAD.LE.LITDY) GO TO 644 WRITE(4,144) IS,ICASE,IZAD GO TO 99 644 DO 47 KP=IMED,IZED KPP=KP-IMED+1 CALL LINE(DYCOE(KPP),KP,IMED,IZED) IF(P(KP).LE.PMAX) GO TO 47 PILX=PMAXBK PMAXBK=PMAX PMAX=P(KP) PMAXM1=P(KP-1) PMAXP1=P(KP+1) DELTAC=PMAX-PMAXM1 DELTAD=PMAXP1-PMAX IF(DELTAC.LT.0.) DELTAC=-DELTAC IF(DELTAD.LT.0.) DELTAD=-DELTAD IF((DELTAC.LT.30.).OR.(DELTAD.LT.30.)) GO TO 47 P(KP)=(P(KP-1)+P(KP+1))/2. WRITE(4,822) PMAX,P(KP) IF(P(KP).LT.PMAXBK) GO TO 47 PMAX=PMAXBK PMAXBK=PILX 47 CONTINUE IF(P(IALF).LE.PLINE) GO TO 147 IF(PMIN.GE.PLINE) CASE=5 IF(PMIN.LT.PLINE) CASE=6 GO TO 145 147 IF(PMAX.GT.PLINE) GO TO 146 IF(PMAX.EQ.PLINE) CASE=1 IF(PMAX.LT.PLINE) CASE=4 GO TO 145 146 DO 246 IY=IMED+1,IZED IF(P(IY).GT.PLINE) GO TO 245 ICHECK=IY 246 CONTINUE 245 VCHECK=V(ICHECK) IF(VCHECK.EQ.V(IMED)) CASE=2 IF(VCHECK.LT.V(IMED)) CASE=3 145 WRITE(3,345) KS,CASE 345 FORMAT(1H ,'FOR CURVE NO ',I3,' CASE= ',I2) AB=V(IMED)-V(IALF) BC=PLINE-P(IMED) AD=PLINE-P(IALF) IF(CASE.NE.5) GO TO 301 BC=-BC AD=-AD 301 ADCBA=.5*AB*(AD+BC) IF(CASE.GT.4) GO TO 302 PROUT(2)=0. PROUT(1)=ADCBA GO TO 310 302 IF(CASE.EQ.6) GO TO 303 PROUT(1)=0. PROUT(2)=ADCBA GO TO 310 303 AD=-AD DO 304 JY=1,ICUR JX=JY+IALF-1 IF(P(JY).GE.PLINE) GO TO 304 R=V(JX-1) GO TO 305 304 CONTINUE 305 BR=V(IMED)-R RA=AB-BR PROUT(1)=.5*BC*BR PROUT(2)=.5*AD*RA 310 DO 311 NB=IALF,IMED NOB=NB-IALF+1 311 DIF(NOB)=DYCO(NOB)-P(NB) CALL QTFE(HV,DIF,PROUT(4),IMAD) DO 312 NC=IMED,IZED NOC=NC-IMED+1 312 DIF(NOC)=P(NC)-DYCOE(NOC) CALL QTFE(HV,DIF,PROUT(5),IZAD) IF(CASE.EQ.6) GO TO 315 IF(CASE.EQ.5) GO TO 313 PROUT(10)=0. GO TO 315 313 PROUT(10)=PROUT(2)-PROUT(4) PROUT(11)=0. 315 IF(CASE.NE.2) GO TO 316 PROUT(11)=0. GO TO 325 316 IF(CASE.EQ.6) GO TO 314 IF(CASE.EQ.5) GO TO 325 IF(CASE.EQ.3) GO TO 317 PROUT(11)=PROUT(1)-PROUT(5) GO TO 325 317 DO 318 ND=ICHECK,IZED NOD=ND-ICHECK+1 318 DIF(NOD)=P(ND)-PLINE IZOD=IZED-ICHECK+1 CALL QTFE(HV,DIF,CLEAR,IZOD) PROUT(11)=PROUT(1)-PROUT(5)+CLEAR GO TO 325 314 DO 319 IC=IALF,IMED IF(P(IC).LT.PLINE) GO TO 320 JCHECK=IC 319 CONTINUE 320 DO 321 ID=IMED,IZED IF(P(ID).GT.PLINE) GO TO 322 KCHECK=ID 321 CONTINUE 322 DO 323 JF=IMED,KCHECK JOF=JF-IMED+1 CALL LINEV(DYC,JF,IALF,IMED) 323 DIF(JOF)=V(JF)-DYC KOC=KCHECK-IMED+1 CALL QTFE(HV,DIF,CLUB,KOC) PROUT(11)=PROUT(1)-CLUB DO 324 KF=IALF,JCHECK KOF=KF-IALF+1 CALL LINEV(DYE,KF,IALF,IMED) 324 DIF(KOF)=DYC-V(KF) JOC=JCHECK-IALF+1 CALL QTFE(HV,DIF,CLAC,JOC) PROUT(10)=PROUT(2)-CLAC 325 PROUT(3)=PROUT(1)+PROUT(2) PROUT(6)=PROUT(4)+PROUT(5) PROUT(12)=PROUT(10)+PROUT(11) PROUT(7)=PROUT(4)-PROUT(2)+PROUT(10) PROUT(8)=PROUT(5)-PROUT(1)+PROUT(11) PROUT(13)=PROUT(7)+PROUT(1)+PROUT(10) PROUT(14)=PROUT(8)+PROUT(2)+PROUT(11) PROUT(9)=PROUT(7)+PROUT(8) PROUT(15)=PROUT(13)+PROUT(14) DO 331 JZZ=1,15 TLIT=PROUT(JZZ)/TIDVOL MOA=MOD(JZZ,3) MO=MOA+1 C WRITE(4,948) MO 948 FORMAT(1H ,'MO=',I4) GO TO (341,342,343), MO 341 TLMIN=TLIT/PERIOD GO TO 331 342 TLMIN=TLIT/PERIOI GO TO 331 343 TLMIN=TLIT/PERIOE 331 WRITE(3,332) JZZ,PHEAD(JZZ),PROUT(JZZ),TLIT,TLMIN 332 FORMAT(1H ,I2,2X,A6,5X,F8.2,5X,F8.4,5X,F8.5) 45 CONTINUE IF(ICASE.EQ.3) GO TO 99 ICASE=ICASE+1 C WRITE(4,945) NOSET,ICASE,LULL DO 676 IC=1,16 INC=IC IF(INBB.LE.255) GO TO 677 676 INBB=INBB-255 677 NBA=INC ISTART=INBB IF(ICASE.EQ.3) GO TO 680 DO 621 JZ=LULL,IIN NPON=NONEUP(JZ)-NONEUP(LULL)+1 IF(NPON.LE.NMAX) GO TO 621 IEND=NONEUP(JZ-1)-NONEUP(LULL)+1 TOUP=UPTO+IEND-1 INBB=TOUP*3-2 IENDB=IEND LULLA=JZ-1 NOSETA=LULLA-LULL NOM=NOSET GO TO 622 621 CONTINUE 680 NOM=NOM+NOSET IEND=NONEUP(LBM)-IENDB+1 622 IF(LULL.EQ.IDO) GO TO 623 NULL=NONEUP(NOSET+1) NULD=NONEDO(NOSET+1) DO 615 IM=LULL+1,IDO LAM=IM-LULL+1 IMM=IM IF(ICASE.EQ.3) IMM=IMM-NOSET NONEDO(LAM)=NONEDO(IMM)-NULL+1 615 NONEUP(LAM)=NONEUP(IMM)-NULL+1 623 LBM=IIN-LULL+1 NOSET=LBM-1 NONEUP(LBM)=NONEUP(IIN)-NULL+1 IF(ICASE.EQ.3) NONEUP(LBM)=NONEUP(LBMM)-NULL+1 NONEDO(1)=NULD-NULL+1 NONEUP(1)=1 IF(ICASE.EQ.3) GO TO 25 LULL=LULLA NOSET=NOSETA LBMM=LBM C WRITE(4,945) NOSET,ICASE,LULL GO TO 25 97 FORMAT(1H1,'HELP, OVERFLEW DIMENSIONS.',5X,I4) 99 STOP END