File MCTIVO.FT (FORTRAN source file)

Directory of image this file is from
This file as a plain text file

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



Feel free to contact me, David Gesswein djg@pdp8online.com with any questions, comments on the web site, or if you have related equipment, documentation, software etc. you are willing to part with.  I am interested in anything PDP-8 related, computers, peripherals used with them, DEC or third party, or documentation. 

PDP-8 Home Page   PDP-8 Site Map   PDP-8 Site Search