C PROTEIN DATA BANK SOURCE CODE STEREO C AUTHOR. M.ROSSMANN C ENTRY DATE. 6/79 UNSUPPORTED C LAST REVISION. 9/79 C PURPOSE. EXTRACT COORDINATES FROM STEREO C PURPOSE. DIAGRAMS. C LANGUAGE. FORTRAN IV, COMPASS(CDC) C C C PROGRAM STEREO(INPUT,OUTPUT,TAPE5=INPUT,TAPE6=OUTPUT,PUNCH,TAPE1) STEREO C C THREE-DIMENSIONAL COORDINATES FROM STEREO DIAGRAMS C C AUTHOR. M. G. ROSSMANN C DEPT. OF BIOLOGICAL SCIENCES C PURDUE UNIVERSITY C WEST LAFAYETTE, INDIANA 47907 C C DATE. MARCH 1979 C C C INPUT. C C CARD 1. MT,IPUNCH,KONST,FISET,VIEWSET,CRIT (3I5,3F5.0) C C C MT = 1 INPUT STEREO DIAGRAM COORDINATES ON TAPE 1 C = 5 INPUT STEREO DIAGRAM COORDINATES AS CARDS ON C TAPE 5 C C IPUNCH = 0 DO NOT PUNCH OUT FINAL X, Y, Z COORDINATES C = 1 PUNCH OUT FINAL X, Y, Z COORDINATES C C KONST = NUMBER OF CONSTRAINTS TO BE APPLIED. C IF 0, IT WILL ASSUME A POLYPEPTIDE CHAIN OF C ALPHA CARBON ATOMS. C C FISET = ANGULAR SEPARATION IN DEGREES. IF 0, IT WILL C SEARCH FOR CORRECT VALUE. C C VIEWSET= VIEWING DISTANCE IN INCHES. IF 0, IT WILL C SEARCH FOR CORRECT VALUE. C C CRIT = CRITERION FOR REMOVING BAD MEASUREMENTS. C DEFAULT VALUE IS 1.5. PRIOR TO PHI, V SEARCH, C PROGRAM USES PHI = 3 DEGREES, V = INFINITY, C AND DISTANCES USED IN CONSTRAINTS. ALL C DISTANCES WHICH ARE OUTSIDE THE FOLLOWING C LIMITS WILL THEN BE REJECTED FROM SEARCH C C DIST .GT. S*CRIT C DIST .LT. S/(CRIT**2) C C S IS THE STANDARD CA-CA DISTANCE OF 3.84 A. C C CARDS 2. ((CONST(K,J),J=1,4),K=1,KONST) (4F5.0) C C THESE ARE THE CONSTRAINTS. C C CONST(K,1) = FIRST I TH ATOM IN CONSTRAINT C CONST(K,2) = FIRST J TH ATOM IN CONSTRAINT (IF NEGATIVE C WILL COUNT BACKWARDS) C CONST(K,3) = LAST I TH ATOM IN CONSTRAINT C CONST(K,4) = DISTANCE S(I,J) BETWEEN I TH AND J TH ATOMS C MEASURED IN ANGSTROMS C C THE DISTANCES BETWEEN SUCCEEDING PAIRS OF ATOMS WILL BE C REFINED AGAINST THE STANDARD ALPHA CARBON - ALPHA CARBON C DISTANCE OF 3.84 ANGSTROMS IF KONST (ABOVE) IS SET TO C ZERO AND THESE CONST(K,J) CARDS OMITTED. THIS AND OTHER C CONSTRAINTS BETWEEN DIFFERENTLY SELECTED ATOM PAIRS MAY C BE SET HERE IF DESIRED. C C IF KONST(K,2)=0 FOR THE K TH CONSTRAINT CARD AN ALPHA C HELIX IS ASSUMED. IN THIS CASE CONST(K,1) SHOULD BE THE C FIRST CARBON ALPHA ATOM IN THE HELIX (CALL IT ATOM I) AND C CONST(K,3) SHOULD BE THE LAST CARBON ALPHA ATOM IN THE C HELIX (CALL IT ATOM J). IN THIS CASE A SERIES OF C CONSTRAINTS IS GENERATED IN PLACE OF THE GIVEN CONSTRAINT C AS FOLLOWS. C THE FIRST SET OF CONSTRAINTS WILL BE FOR C ATOM I TO ATOM I+2 C ATOM I+1 TO ATOM I+3 C ETC. UNTIL I+N=J C THE SECOND SET OF CONSTRAINTS WILL BE FOR C ATOM I TO ATOM I+3 C ATOM I+1 TO ATOM I+4 C ETC. UNTIL I+N=J C THE LAST CONSTRAINT WILL BE FOR C ATOM I TO ATOM J C BY ASSUMING THE PARAMETERS FOR AN ALPHA HELIX, THE C PROGRAM WORKS OUT THE APPROPRIATE VALUES FOR S(I,J) IN C SUBROUTINE HELIX. C C EXAMPLES OF PARTICULAR CONSTRAINTS THAT MAY BE SET ARE C C EXAMPLE 1. AN ALPHA CARBON CHAIN OF N ATOMS. C C CONST(K,1)=1 C CONST(K,2)=2 C CONST(K,3)=N-1 C CONST(K,4)=3.84 C C EXAMPLE 2. TWO ANTIPARALLEL STRANDS, EACH N RESIDUES C LONG, STARTING AT RESIDUE NUMBERS P AND Q. C C CONST(K,1)=P C CONST(K,2)=-(Q+N-1) C CONST(K,3)=P+N-1 C CONST(K,4)=4.72 (NOTE. THERE ARE TWO DIFFERENT CA-CA C DISTANCES BETWEEN ANTIPARALLEL C STRANDS AND THIS NUMBER IS AN C AVERAGE) C C EXAMPLE 3. AN ALPHA HELIX N RESIDUES LONG STARTING AT C RESIDUE P. C C CONST(K,1)=P C CONST(K,2)=P+4 C CONST(K,3)=P+N-4 C CONST(K,4)=6.20 C C THE PROGRAM WILL MINIMIZE THE SUM OVER ALL THE CONSTRAINTS C OF C SUM(((X(I)-X(J))**2-S(I,J)**2)**2) C C CARDS 3. XL,YL,XR,YR (4F10.4) C C THESE ARE THE LEFT AND RIGHT STEREO DIAGRAM COORDINATES. C THEY CAN BE PUT ON TAPE 1 (MT=1) OR IN THE INPUT STREAM C (MT=5). IT IS ASSUMED THAT THE COORDINATES WILL BE GIVEN C IN MICRONS, SO AS TO PROVIDE THE VIEWING DISTANCE IN C INCHES. THE PROGRAM WILL WORK EVEN IF THE COORDINATES C ARE IN ANY OTHER UNITS BUT THE V DISTANCE WILL NOT BE IN C INCHES BUT ON A CORRESPONDING ARBITRARY SCALE. C C TERMINATION IS GIVEN BY XL = 99999.0 C C C OUTPUT. C C THE OUTPUT IS HOPEFULLY SELF EXPLANATORY BUT ESSENTIALLY IT C CONSISTS OF THE FOLLOWING SEQUENTIAL ITEMS. C C 1. ECHO OF CARD 1. C C 2. ECHO OF CARDS 3. C C 3. REFINEMENT OF ORIENTATION OF X,Y COORDINATES TO MINIMIZE C Y SEPARATION IN LEFT AND RIGHT EQUIVALENT ATOMS. C C 4. X AND Y REFINED TO SEPARATE ORIGINS. C C 5. STATISTICS ON SEPARATION OF X AND Y COORDINATES. C INITIAL DETERMINATION OF PHI. C C 6. SEARCH FOR BEST PHI AND V. C C 7. BEST VALUE OF PHI AND V. C C 8. X, Y, Z THREE-DIMENSIONAL COORDINATES FOR EACH CYCLE C OF REFINEMENT. C C A. 3 CYCLES OF Z REFINEMENT C B. 3 CYCLES OF Y REFINEMENT C C. 3 CYCLES OF X REFINEMENT C C SHIFTS (IN ANGSTROMS), COORDINATES AND RMS FOR EACH C CONSTRAINT ARE GIVEN AFTER EACH CYCLE. C C COMMON DTR,NUM,UM,KONST,COORD(350,2,2),XYZ(350,3),CONST(100,4), STEREO 1DKEEP(350) STEREO COMMON /WORK/ ZKEEP(350),X(350),Y(350),Z(350),D(350),FILLER(13300)STEREO 1,CRIT STEREO PI=4.0*ATAN2(1.0,1.0) STEREO DTR=PI/180.0 STEREO READ(5,80) MT,IPUNCH,KONST,FISET,VIEWSET,CRIT STEREO 80 FORMAT(3I5,3F5.0) STEREO IF(MT.EQ.0) MT=5 STEREO IF(VIEWSET.EQ.0.0) VIEWSET=10.0 STEREO IF(CRIT.EQ.0.0) CRIT=1.5 STEREO WRITE(6,81) MT,IPUNCH,KONST,FISET,VIEWSET,CRIT STEREO 81 FORMAT(* MT*I2*IPUNCH*I2*, KONST*I3*, FI*F5.2*, VIEW DIST(INCH)* STEREO 1F6.2*, REJECTION CRIT* F6.2) STEREO IF(KONST.EQ.0) GO TO 36 STEREO DO 26 K=1,KONST STEREO READ(5,88) (CONST(K,J),J=1,4) STEREO 88 FORMAT(4F5.0) STEREO IF(CONST(K,2).EQ.0.0) CALL HELIX(K) STEREO 26 CONTINUE STEREO 36 WRITE(6,98) STEREO 98 FORMAT(*1*14X*LEFT*16X*RIGHT*/1X,2(9X*X*9X*Y*)) STEREO DO 10 I=1,350 STEREO READ(MT,99) ((COORD(I,K,J),J=1,2),K=1,2) STEREO 99 FORMAT(4F10.4) STEREO IF(COORD(I,1,1).EQ.99999.0) GO TO 11 STEREO WRITE(6,97) I,((COORD(I,K,J),J=1,2),K=1,2) STEREO 97 FORMAT(1X,I4,4F10.2,5X,F10.2) STEREO 10 CONTINUE STEREO NUM=350 STEREO GO TO 12 STEREO 11 NUM=I-1 STEREO 12 UM=NUM STEREO DO 50 N=1,2 STEREO RS=0.0 STEREO RR=0.0 STEREO SS=0.0 STEREO DO 51 I=1,NUM STEREO DS=COORD(I,1,1)-COORD(I,2,1) STEREO DR=COORD(I,1,2)-COORD(I,2,2) STEREO RS=RS+DR*DS STEREO RR=RR+DR*DR STEREO SS=SS+DS*DS STEREO 51 CONTINUE STEREO B=2.0*RS STEREO A=SS-RR STEREO PSI=ATAN2(B,A) STEREO PSI=-PSI/2.0 STEREO DEGPSI=PSI/DTR STEREO R=SQRT(RR/UM) STEREO S=SQRT(SS/UM) STEREO WRITE(6,52) R,S,DEGPSI STEREO 52 FORMAT(///* RMS DY*F8.1*, RMS DX*F8.1*, PSI*F8.1) STEREO CP=COS(PSI) STEREO SP=SIN(PSI) STEREO DO 53 I=1,NUM STEREO DO 54 K=1,2 STEREO R=COORD(I,K,1)*SP+COORD(I,K,2)*CP STEREO S=COORD(I,K,1)*CP-COORD(I,K,2)*SP STEREO COORD(I,K,1)=S STEREO COORD(I,K,2)=R STEREO 54 CONTINUE STEREO 53 CONTINUE STEREO 50 CONTINUE STEREO IF(KONST.NE.0) GO TO 37 STEREO CONST(1,1)=1.0 STEREO CONST(1,2)=2.0 STEREO CONST(1,3)=UM-1.0 STEREO CONST(1,4)=3.84 STEREO KONST=1 STEREO 37 WRITE(6,87) ((CONST(K,J),J=1,4),K=1,KONST) STEREO 87 FORMAT(1X,3F5.0,F6.2) STEREO SXL=0.0 STEREO SYL=0.0 STEREO SXR=0.0 STEREO SYR=0.0 STEREO DO 13 I=1,NUM STEREO SXL=SXL+COORD(I,1,1) STEREO SYL=SYL+COORD(I,1,2) STEREO SXR=SXR+COORD(I,2,1) STEREO SYR=SYR+COORD(I,2,2) STEREO 13 CONTINUE STEREO SXL=SXL/UM STEREO SYL=SYL/UM STEREO SXR=SXR/UM STEREO SYR=SYR/UM STEREO XERR=0.0 STEREO YERR=0.0 STEREO WRITE(6,98) STEREO DO 14 I=1,NUM STEREO COORD(I,1,1)=COORD(I,1,1)-SXL STEREO COORD(I,1,2)=COORD(I,1,2)-SYL STEREO COORD(I,2,1)=COORD(I,2,1)-SXR STEREO COORD(I,2,2)=COORD(I,2,2)-SYR STEREO DEL=COORD(I,1,1)-COORD(I,2,1) STEREO WRITE(6,97) I, ((COORD(I,K,J),J=1,2),K=1,2),DEL STEREO XERR=XERR+DEL**2 STEREO YERR=YERR+(COORD(I,1,2)-COORD(I,2,2))**2 STEREO 14 CONTINUE STEREO XERR=SQRT(XERR/UM) STEREO YERR=SQRT(YERR/UM) STEREO WRITE(6,89) XERR,YERR STEREO 89 FORMAT(*0 RMS X,Y* 2F10.2) STEREO DXSQ=0.0 STEREO DYSQ=0.0 STEREO DZSQ=0.0 STEREO DO 30 I=2,NUM STEREO J=I-1 STEREO DXSQ=DXSQ+(COORD(J,1,1)-COORD(I,1,1))**2 STEREO DYSQ=DYSQ+(COORD(J,1,2)-COORD(I,1,2))**2 STEREO DELJ=COORD(J,1,1)-COORD(J,2,1) STEREO DELI=COORD(I,1,1)-COORD(I,2,1) STEREO DZSQ=DZSQ+(DELJ-DELI)**2 STEREO 30 CONTINUE STEREO DSQ=(DXSQ+DYSQ)/2.0 STEREO FIEQ=0.5*ASIN(SQRT(DZSQ/DSQ))/DTR STEREO WRITE(6,90) FIEQ STEREO 90 FORMAT(* FI BASED ON EQUIVALENCING DXSQ,DYSQ,DZSQ* F10.2) STEREO WRITE(6,85) STEREO 85 FORMAT(///* SET UP REASONABLE SCALE FACTOR TO PERMIT ELIMINATION STEREO 1OF GROSS ERRORS*) STEREO RMSMIN=0.0 STEREO DIST=0.0 STEREO DO 39 I=1,10 STEREO CALL CENTRAL(3.0,50.0,DIST,RMSMIN,FIMIN,VMIN) STEREO 39 CONTINUE STEREO FI=1.0 STEREO DO 15 K=1,20 STEREO WRITE(6,92) STEREO 92 FORMAT(///6X*FI*6X*V DRMS(A.)*) STEREO FI=FI+0.25 STEREO V=-50.0 STEREO DO 22 L=1,20 STEREO V=V+5.0 STEREO IF(V.EQ.0.0) GO TO 22 STEREO DIST=-1.0 STEREO CALL CENTRAL(FI,V,DIST,RMSMIN,FIMIN,VMIN) STEREO 22 CONTINUE STEREO 15 CONTINUE STEREO IF(FISET) 31,23,32 STEREO 31 FI=FIEQ STEREO GO TO 33 STEREO 32 FI=FISET STEREO 33 V=VIEWSET STEREO RMSMIN=0.0 STEREO GO TO 34 STEREO 23 FI=FIMIN STEREO V=VMIN STEREO 34 RMSMIN=0.0 STEREO CAY=-1.0 STEREO CALL CENTRAL(FI,V,CAY,RMSMIN,FIMIN,VMIN) STEREO YERR=YERR*CAY STEREO RMSMIN=RMSMIN*CAY STEREO WRITE(6,94) FIMIN,V,YERR STEREO 94 FORMAT(* FIMIN*F7.3*, VIEWING DIST(INCH)*F6.1*, YERR(A.)*F6.2) STEREO WRITE(6,93) STEREO 93 FORMAT(///* NUM*3X*X(A.)*3X*Y(A.)*3X*Z(A.)*8X*D(A.)*) STEREO DO 27 I=1,NUM STEREO DO 25 J=1,3 STEREO XYZ(I,J)=XYZ(I,J)*CAY STEREO 25 CONTINUE STEREO ZKEEP(I)=ZKEEP(I)*CAY STEREO DKEEP(I)=DKEEP(I)*CAY STEREO 27 CONTINUE STEREO DO 29 I=1,NUM STEREO WRITE(6,95) I,(XYZ(I,J),J=1,3),DKEEP(I) STEREO 29 CONTINUE STEREO DO 40 K=1,3 STEREO KR=4-K STEREO DO 41 I=1,NUM STEREO ZKEEP(I)=XYZ(I,KR) STEREO 41 CONTINUE STEREO DO 28 N=1,3 STEREO CALL REFINE(KR) STEREO WRITE(6,86) N,KR STEREO 86 FORMAT(//////* AFTER CYCLE*I2* WHILE REFINING COORDINATE(*I1*)*) STEREO WRITE(6,93) STEREO DO 21 I=1,NUM STEREO WRITE(6,95) I,(XYZ(I,J),J=1,3),DKEEP(I) STEREO 95 FORMAT(1X,I4,3F8.1,5X,F8.1) STEREO IF(K.NE.3) GO TO 21 STEREO IF((IPUNCH.EQ.0).OR.(N.NE.3)) GO TO 21 STEREO PUNCH 91, I,(XYZ(I,J),J=1,3) STEREO 91 FORMAT(I5,3F10.1) STEREO 21 CONTINUE STEREO 28 CONTINUE STEREO 40 CONTINUE STEREO STOP STEREO END STEREO SUBROUTINE CENTRAL(FI,V,DIST,RMSMIN,FIMIN,VMIN) STEREO COMMON DTR,NUM,UM,KONST,COORD(350,2,2),XYZ(350,3),CONST(100,4), STEREO 1DKEEP(350) STEREO COMMON /WORK/ ZKEEP(350),X(350),Y(350),Z(350),D(350),FILLER(13300)STEREO 1,CRIT STEREO VMIC=V*254.0 STEREO SFI=SIN(FI*DTR) STEREO CFI=COS(FI*DTR) STEREO DO 16 I=1,NUM STEREO X(I)=(COORD(I,1,1)+COORD(I,2,1))/(2.0*CFI) STEREO Y(I)=(COORD(I,1,2)+COORD(I,2,2))/2.0 STEREO DEL=-(COORD(I,2,1)-COORD(I,1,1)) STEREO Z(I)=DEL/(2.0*SFI) STEREO Q=1.0/(1.0-(DEL/(2.0*VMIC*SFI))) STEREO IF(ABS(V).GT.45.0) Q=1.0 STEREO X(I)=X(I)*Q STEREO Y(I)=Y(I)*Q STEREO Z(I)=Z(I)*Q STEREO 16 CONTINUE STEREO SDSQ=0.0 STEREO SD=0.0 STEREO SM=0.0 STEREO SN=0.0 STEREO JOT=0 STEREO DO 10 K=1,KONST STEREO I1=CONST(K,1) STEREO I2=CONST(K,3) STEREO J1=ABS(CONST(K,2)) STEREO INC=1 STEREO IF(CONST(K,2).LT.0.0) INC=-1 STEREO STAND=CONST(K,4) STEREO STCAY1=STAND*CRIT STEREO STCAY2=STAND/(CRIT*CRIT) STEREO DO 17 I=I1,I2 STEREO J=J1+(I-I1)*INC STEREO IF(J.GT.NUM) GO TO 17 STEREO JOT=JOT+1 STEREO IF(DIST.GT.0.0) FILLER(JOT)=0.0 STEREO DSQ=((X(J)-X(I))**2)+((Y(J)-Y(I))**2)+((Z(J)-Z(I))**2) STEREO P=SQRT(DSQ) STEREO IF(K.EQ.1) D(I)=P STEREO IF(DIST.EQ.0.0) GO TO 11 STEREO IF((DIST.LT.0.0).AND.(FILLER(JOT).EQ.0.0)) GO TO 17 STEREO IF((DIST.LT.0.0).AND.(FILLER(JOT).NE.0.0)) GO TO 11 STEREO R=P*DIST STEREO IF((R.GT.STCAY1).OR.(R.LT.STCAY2)) GO TO 17 STEREO 11 SD=SD+P*STAND STEREO SDSQ=SDSQ+P*P STEREO SM=SM+STAND*STAND STEREO SN=SN+1.0 STEREO IF(DIST.GT.0.0) FILLER(JOT)=1.0 STEREO 17 CONTINUE STEREO 10 CONTINUE STEREO CAY=SD/SDSQ STEREO DRMS=CAY*CAY*SDSQ-2.0*CAY*SD+SM STEREO DRMS=SQRT(DRMS/SN) STEREO WRITE(6,96) FI,V,DRMS,SN STEREO 96 FORMAT(1X,F7.3,F8.3,E12.5,F8.0) STEREO IF(RMSMIN.EQ.0.0) GO TO 19 STEREO IF(DRMS.GT.RMSMIN) RETURN STEREO 19 DO 20 I=1,NUM STEREO XYZ(I,1)=X(I) STEREO XYZ(I,2)=Y(I) STEREO XYZ(I,3)=Z(I) STEREO DKEEP(I)=D(I) STEREO ZKEEP(I)=Z(I) STEREO 20 CONTINUE STEREO DIST=CAY STEREO RMSMIN=DRMS STEREO FIMIN=FI STEREO VMIN=V STEREO RETURN STEREO END STEREO SUBROUTINE HELIX(K) STEREO COMMON DTR,NUM,UM,KONST,COORD(350,2,2),XYZ(350,3),CONST(100,4), STEREO 1DKEEP(350) STEREO I1=CONST(K,1) STEREO I2=CONST(K,3) STEREO NHE=I2-I1-1 STEREO IF(NHE.LT.1) RETURN STEREO DO 10 L=1,NHE STEREO J1=I1+L+1 STEREO IF(J1.GT.I2) RETURN STEREO N=J1-I1 STEREO ANGLE=N*99.6*DTR STEREO X=2.29*(1.0-COS(ANGLE)) STEREO Y=2.29*SIN(ANGLE) STEREO Z=1.496*FLOAT(N) STEREO D=SQRT(X*X+Y*Y+Z*Z) STEREO CONST(K,1)=I1 STEREO CONST(K,2)=J1 STEREO CONST(K,3)=I2-L-1 STEREO CONST(K,4)=D STEREO K=K+1 STEREO KONST=KONST+1 STEREO 10 CONTINUE STEREO K=K-1 STEREO KONST=KONST-1 STEREO RETURN STEREO END STEREO SUBROUTINE REFINE(KR) STEREO DIMENSION A(20,20),B(20),C(20),S(100,2) STEREO COMMON DTR,NUM,UM,KONST,COORD(350,2,2),XYZ(350,3),CONST(100,4), STEREO 1DKEEP(350) STEREO COMMON /WORK/ ZOBS(350),TRIX(35,20,20),RHS(35,20) STEREO W=1.0 STEREO MAX=(NUM+9)/10 STEREO KOP1=KONST+1 STEREO DO 31 K=1,KOP1 STEREO S(K,1)=0.0 STEREO S(K,2)=0.0 STEREO 31 CONTINUE STEREO DO 13 M=1,35 STEREO DO 14 I=1,20 STEREO RHS(M,I)=0.0 STEREO DO 15 J=1,20 STEREO TRIX(M,I,J)=0.0 STEREO 15 CONTINUE STEREO 14 CONTINUE STEREO 13 CONTINUE STEREO DO 10 K=1,KONST STEREO I1=CONST(K,1) STEREO I2=CONST(K,3) STEREO J1=ABS(CONST(K,2)) STEREO INC=1 STEREO IF(CONST(K,2).LT.0.0) INC=-1 STEREO DOBS=CONST(K,4) STEREO DO 11 I=I1,I2 STEREO J=J1+(I-I1)*INC STEREO IF(J.GT.NUM) GO TO 11 STEREO DSQ=0.0 STEREO DO 12 L=1,3 STEREO DSQ=DSQ+(XYZ(I,L)-XYZ(J,L))**2 STEREO 12 CONTINUE STEREO DCALC=SQRT(DSQ) STEREO S(K,1)=S(K,1)+(DOBS-DCALC)**2 STEREO S(K,2)=S(K,2)+1.0 STEREO DIFF=XYZ(I,KR)-XYZ(J,KR) STEREO DZI=DIFF/DCALC STEREO DZJ=-DIFF/DCALC STEREO M=(I+9)/10 STEREO N=M-1 STEREO IM=I-(M-1)*10 STEREO IN=I-(N-1)*10 STEREO JM=J-(M-1)*10 STEREO JN=J-(N-1)*10 STEREO IF((JM.GT.20).OR.(JM.LT.1)) M=0 STEREO IF((JN.GT.20).OR.(JN.LT.1)) N=0 STEREO IF(M.EQ.0) GO TO 19 STEREO TRIX(M,IM,IM)=TRIX(M,IM,IM)+DZI*DZI STEREO TRIX(M,IM,JM)=TRIX(M,IM,JM)+DZI*DZJ STEREO TRIX(M,JM,IM)=TRIX(M,JM,IM)+DZJ*DZI STEREO TRIX(M,JM,JM)=TRIX(M,JM,JM)+DZJ*DZJ STEREO RHS(M,IM)=RHS(M,IM)+(DOBS-DCALC)*DZI STEREO RHS(M,JM)=RHS(M,JM)+(DOBS-DCALC)*DZJ STEREO 19 IF(N.EQ.0) GO TO 11 STEREO TRIX(N,IN,IN)=TRIX(N,IN,IN)+DZI*DZI STEREO TRIX(N,IN,JN)=TRIX(N,IN,JN)+DZI*DZJ STEREO TRIX(N,JN,IN)=TRIX(N,JN,IN)+DZJ*DZI STEREO TRIX(N,JN,JN)=TRIX(N,JN,JN)+DZJ*DZJ STEREO RHS(N,IN)=RHS(N,IN)+(DOBS-DCALC)*DZI STEREO RHS(N,JN)=RHS(N,JN)+(DOBS-DCALC)*DZJ STEREO 11 CONTINUE STEREO 10 CONTINUE STEREO IF(W.EQ.0) GO TO 17 STEREO DO 18 I=1,NUM STEREO DOBS=ZOBS(I) STEREO DCALC=XYZ(I,KR) STEREO S(KOP1,1)=S(KOP1,1)+(DOBS-DCALC)**2 STEREO S(KOP1,2)=S(KOP1,2)+1.0 STEREO M=(I+9)/10 STEREO N=M-1 STEREO IM=I-(M-1)*10 STEREO IN=I-(N-1)*10 STEREO TRIX(M,IM,IM)=TRIX(M,IM,IM)+W*W STEREO RHS(M,IM)=RHS(M,IM)+W*(DOBS-DCALC) STEREO IF(N.EQ.0) GO TO 18 STEREO TRIX(N,IN,IN)=TRIX(N,IN,IN)+W*W STEREO RHS(N,IN)=RHS(N,IN)+W*(DOBS-DCALC) STEREO 18 CONTINUE STEREO C STEREO C END ROUTINE STEREO C STEREO 17 WRITE(6,96) STEREO 96 FORMAT(///* SHIFTS*) STEREO DO 20 I=1,NUM,10 STEREO M=(I+9)/10 STEREO K=I+19 STEREO IF(K.GT.NUM) K=NUM STEREO DO 21 I1=I,K STEREO L1=I1-I+1 STEREO DO 22 J1=I,K STEREO L2=J1-I+1 STEREO A(L1,L2)=TRIX(M,L1,L2) STEREO 22 CONTINUE STEREO B(L1)=RHS(M,L1) STEREO 21 CONTINUE STEREO N=K-I+1 STEREO CALL LINEQ1(A,B,C,20,N,1,T) STEREO WRITE(6,99) I,(C(II),II=1,N) STEREO 99 FORMAT(1X,I4,3X,20F5.1) STEREO K=I+9 STEREO IF(K.GT.NUM) K=NUM STEREO DO 23 J=I,K STEREO L=J-I+1 STEREO XYZ(J,KR)=XYZ(J,KR)+C(L) STEREO 23 CONTINUE STEREO 20 CONTINUE STEREO WRITE(6,97) STEREO 97 FORMAT(///* CONSTRAINT RMS(A.) NUM*) STEREO DO 32 K=1,KOP1 STEREO IF(S(K,2).EQ.0) GO TO 33 STEREO S(K,1)=SQRT(S(K,1)/S(K,2)) STEREO 33 WRITE(6,98) K,S(K,1),S(K,2) STEREO 98 FORMAT(1X,I10,F9.2,F5.0) STEREO 32 CONTINUE STEREO DO 39 I=1,NUM STEREO J=I+1 STEREO IF(J.GT.NUM) GO TO 39 STEREO DSQ=0.0 STEREO DO 38 L=1,3 STEREO DSQ=DSQ+(XYZ(I,L)-XYZ(J,L))**2 STEREO 38 CONTINUE STEREO DKEEP(I)=SQRT(DSQ) STEREO 39 CONTINUE STEREO RETURN STEREO END STEREO SUBROUTINE LINEQ1 (A,B,X,ND,N,NR,S,C,N1,N2,R,N3,E,N4) LINEQ1 REAL A(ND,ND),B(ND,NR),X(ND,NR) LINEQ1 REAL ARITH1,C(N1,N2),R(N3),E(N4) LINEQ1 INTEGER S LINEQ1 C LINEQ1 C ..................................................................LINEQ1 C LINEQ1 C LINEQ1 C SUBROUTINE LINEQ1 LINEQ1 C LINEQ1 C DECKNAME - LINEQ1 LINEQ1 C PURPOSE LINEQ1 C SOLVES THE REAL MATRIX EQUATION AX=B WITH NR RIGHT-HAND LINEQ1 C SIDES. LINEQ1 C LINEQ1 C USAGE LINEQ1 C CALL LINEQ1(A,B,X,ND,N,NR,S) LINEQ1 C LINEQ1 C DESCRIPTION OF PARAMETERS LINEQ1 C A - (N X N) REAL COEFFICIENT MATRIX. LINEQ1 C B - (N X NR) REAL RIGHT-HAND SIDE ARRAY. LINEQ1 C X - (N X NR) REAL ARRAY FOR RETURN OF SOLUTION LINEQ1 C VECTORS. LINEQ1 C ND - THE NUMBER OF ROWS FOR THE ARRAYS A, B, AND X LINEQ1 C IN THE DIMENSION STATEMENT IN THE USER PROGRAM.LINEQ1 C N - THE NUMBER OF EQUATIONS TO BE SOLVED. LINEQ1 C NR - THE NUMBER OF RIGHT-HAND SIDES TO BE SOLVED. LINEQ1 C S - INTEGER VARIABLE RETURNED NON-ZERO ONLY IF LINEQ1 C MATRIX A IS SINGULAR TO MACHINE ACCURACY. LINEQ1 C LINEQ1 C REMARKS LINEQ1 C ARRAYS A AND B ARE NOT DESTROYED. LINEQ1 C LINEQ1 C EXTRA PARAMETERS IN THE ACTUAL FORMAL PARAMETER LIST LINEQ1 C ARE USED IN CONJUNCTION WITH THE SUBROUTINE DYNAMIC. LINEQ1 C LINEQ1 C AT EXECUTION TIME, THE FIELD LENGTH OF YOUR PROGRAM WILL BELINEQ1 C INCREASED FOR TEMPORARY STORAGE NEEDED BY THIS SUBROUTINE. LINEQ1 C LINEQ1 C METHOD LINEQ1 C THE MATRIX A IS FACTORED INTO LOWER AND UPPER TRIANGULAR LINEQ1 C MATRICES L AND U AND THEN THE EQUATIONS LZ=B AND UX=Z ARE LINEQ1 C SOLVED IN TURN. DOUBLE PRECISION ACCUMULATION OF INNER LINEQ1 C PRODUCTS AND ITERATIVE REFINEMENT ARE USED SO SOLUTIONS LINEQ1 C ARE VERY ACCURATE WHENEVER S IS RETURNED EQUAL TO ZERO. LINEQ1 C LINEQ1 C RALSTON AND WILF MATHEMATICAL METHODS FOR DIGITAL LINEQ1 C COMPUTERS VOLUME 2 WILEY 1967. LINEQ1 C LINEQ1 C WRITTEN BY DAVID S. DODSON, 06/01/70 LINEQ1 C COMPUTER SCIENCES DEPARTMENT LINEQ1 C PURDUE UNIVERSITY LINEQ1 C LINEQ1 C ..................................................................LINEQ1 C LINEQ1 C LINEQ1 C ALLOCATE TEMPORARY STORAGE USING DYNAMIC SUBROUTINE. LINEQ1 C LINEQ1 CALL KLUDGE1 LINEQ1 CALL SETSTAK (N*N+2*N+4) LINEQ1 CALL DYNAMIC (C,N,N) LINEQ1 CALL DYNAMIC (R,N) LINEQ1 CALL DYNAMIC (E,N) LINEQ1 C LINEQ1 C FORM EQUILIBRATION FACTORS IN VECTOR E. LINEQ1 C LINEQ1 DO 12 I=1,N LINEQ1 P=0.0 LINEQ1 DO 10 J=1,N LINEQ1 C(I,J)=A(I,J) LINEQ1 10 P=AMAX1(ABS(C(I,J)),P) LINEQ1 IF(P.EQ.0.0)GO TO 73 LINEQ1 12 E(I)=1.0/P LINEQ1 C LINEQ1 C FACTOR COEFFICIENT MATRIX WITH PARTIAL PIVOTING. LINEQ1 C LINEQ1 M=1 LINEQ1 14 MM=M-1 LINEQ1 P=0.0 LINEQ1 DO 22 I=M,N LINEQ1 C(I,M)=ARITH1(C(I,M),MM,C(I,1),N,C(1,M),1) LINEQ1 Q=E(I)*ABS(C(I,M)) LINEQ1 IF(P.GE.Q)GO TO 22 LINEQ1 P=Q LINEQ1 K=I LINEQ1 22 CONTINUE LINEQ1 IF(N+P.EQ.N)GO TO 73 LINEQ1 IF(M.EQ.K)GO TO 30 LINEQ1 DO 28 J=1,N LINEQ1 P=C(M,J) LINEQ1 C(M,J)=C(K,J) LINEQ1 28 C(K,J)=P LINEQ1 E(K)=E(M) LINEQ1 30 E(M)=K LINEQ1 IF(M.EQ.N)GO TO 37 LINEQ1 MP=M+1 LINEQ1 DO 34 J=MP,N LINEQ1 34 C(M,J)=ARITH1(C(M,J),MM,C(M,1),N,C(1,J),1)/C(M,M) LINEQ1 M=MP LINEQ1 GO TO 14 LINEQ1 C LINEQ1 C BACK SUBSTITUTE RIGHT-HAND SIDES WITH ITERATIVE REFINEMENT. LINEQ1 C LINEQ1 37 IF(NR.LE.0)GO TO 71 LINEQ1 DO 68 M=1,NR LINEQ1 P=0.0 LINEQ1 Q=0.0 LINEQ1 DO 43 I=1,N LINEQ1 R(I)=B(I,M) LINEQ1 43 X(I,M)=0.0 LINEQ1 44 DO 48 I=1,N LINEQ1 K=E(I) LINEQ1 T=R(K) LINEQ1 R(K)=R(I) LINEQ1 48 R(I)=ARITH1(T,I-1,C(I,1),N,R(1),1)/C(I,I) LINEQ1 I=N LINEQ1 GO TO 52 LINEQ1 51 R(I)=ARITH1(R(I),N-I,C(I,IP),N,R(IP),1) LINEQ1 52 IP=I LINEQ1 I=I-1 LINEQ1 IF(I.GT.0)GO TO 51 LINEQ1 T=P LINEQ1 P=0.0 LINEQ1 DO 59 I=1,N LINEQ1 P=AMAX1(ABS(R(I)),P) LINEQ1 59 X(I,M)=X(I,M)+R(I) LINEQ1 C LINEQ1 C TEST FOR CONVERGENCE OF ITERATIVE REFINEMENT. LINEQ1 C LINEQ1 IF(P.EQ.0.0)GO TO 68 LINEQ1 IF(Q.EQ.0.0)Q=P LINEQ1 IF(Q+P.EQ.Q)GO TO 68 LINEQ1 IF(T.NE.0.0.AND.P+P.GT.T)GO TO 67 LINEQ1 DO 65 I=1,N LINEQ1 65 R(I)=ARITH1(B(I,M),N,A(I,1),ND,X(1,M),1) LINEQ1 GO TO 44 LINEQ1 67 IF(Q+P/N.NE.Q)GO TO 73 LINEQ1 68 CONTINUE LINEQ1 C LINEQ1 C SET NON-SINGULAR/SINGULAR FLAG AND RETURN. LINEQ1 C LINEQ1 71 S=0 LINEQ1 RETURN LINEQ1 C LINEQ1 73 S=1 LINEQ1 RETURN LINEQ1 C LINEQ1 END LINEQ1 IDENT DYNAMIC DYNAMIC DYNAMIC DYNAMIC ENTRY DYNAMIC DYNAMIC ENTRY EQUATE DYNAMIC ENTRY CONNECT DYNAMIC ENTRY KLUDGE1 DYNAMIC ENTRY RSTSTAK DYNAMIC ENTRY SETSTAK DYNAMIC ENTRY DOUBLE DYNAMIC ENTRY COMPLEX DYNAMIC ENTRY DYNASET DYNAMIC DYNAMIC SST DYNAMIC SPACE 4 DYNAMIC *** DYNAMIC - DYNAMIC STORAGE ALLOCATION PACKAGE. DYNAMIC * T. J. AIRD AND DAVID S. DODSON, 1968. DYNAMIC SPACE 4 DYNAMIC *** DYNAMIC PROVIDES ALLOCATION, COMMON, AND EQUIVALENCE OF DYNAMIC * ARRAYS IN RUN/FUN/MNF FORTRAN PROGRAMS AT EXECUTION TIME. DYNAMIC SPACE 4 DYNAMIC **** ASSEMBLY CONSTANTS. DYNAMIC DYNAMIC DYNAMIC N SET 10 NUMBER OF RETURN STACK ENTRIES. DYNAMIC **** DYNAMIC TITLE DYNAMIC - DYNAMIC STORAGE ALLOCATION PACKAGE. DYNAMIC DYNAMIC TITLE SUBROUTINE DYNAMIC. DYNAMIC * SUBROUTINE DYNAMIC (N,I1,I2,I3) DYNAMIC DYNAMIC DYNAMIC VFD 42/0LDYNAMIC,18/4 DYNAMIC DYNAMIC PS 0 DYNAMIC + RJ KCCHECK DYNAMIC - LT B0,B0,DYNAMIC-1 DYNAMIC MX6 0 DYNAMIC SA1 DYNAMIC DYNAMIC AX1 30 DYNAMIC DYN1 SX7 B1-377700B DYNAMIC NG X7,DYN2 DYNAMIC SA7 DYNB DYNAMIC SB1 DYNB DYNAMIC DYN2 SA1 X1-1 DYNAMIC SX2 X1 DYNAMIC LX1 36 DYNAMIC AX1 54 DYNAMIC SX0 X1-1 DYNAMIC IX0 X0-X6 DYNAMIC NG X0,DYN7 DYNAMIC SB7 X0-3 DYNAMIC GT B7,B0,DYN7 DYNAMIC SA1 X2 DYNAMIC IX2 X2-X1 DYNAMIC SA0 X2 DYNAMIC SA2 B1 DYNAMIC ZR X2,DYN7 DYNAMIC BX3 X2 DYNAMIC AX3 60 DYNAMIC BX2 X2-X3 DYNAMIC IX2 X0+X2 DYNAMIC SX1 X1 DYNAMIC IX1 X1-X2 DYNAMIC NG X1,DYN7 DYNAMIC SX1 B0 DYNAMIC SX3 1 DYNAMIC BX4 X3 DYNAMIC BX5 X3 DYNAMIC SB7 X0 DYNAMIC ZR B7,DYN3 DYNAMIC SA3 B2 DYNAMIC SB7 X3 DYNAMIC LE B7,B0,DYN7 DYNAMIC SX7 X3 DYNAMIC BX7 X7-X3 DYNAMIC NZ X7,DYN7 DYNAMIC SB7 X0-1 DYNAMIC ZR B7,DYN3 DYNAMIC SA4 B3 DYNAMIC SB7 X4 DYNAMIC LE B7,B0,DYN7 DYNAMIC SX7 X4 DYNAMIC BX7 X7-X4 DYNAMIC NZ X7,DYN7 DYNAMIC SB7 X0-2 DYNAMIC ZR B7,DYN3 DYNAMIC SA5 B4 DYNAMIC SB7 X5 DYNAMIC LE B7,B0,DYN7 DYNAMIC SX7 X5 DYNAMIC BX7 X7-X5 DYNAMIC NZ X7,DYN7 DYNAMIC DYN3 NZ X6,DYN4 DYNAMIC DX2 X3*X4 DYNAMIC DX2 X2*X5 DYNAMIC SA1 B1 DYNAMIC AX1 60 DYNAMIC BX1 X1*X2 DYNAMIC IX1 X1+X2 DYNAMIC DYN4 IX6 X0+X1 DYNAMIC LX4 18 DYNAMIC LX5 36 DYNAMIC IX7 X3+X4 DYNAMIC IX7 X5+X7 DYNAMIC SA6 DYNA DYNAMIC SB7 B1 DYNAMIC SB1 A6 DYNAMIC + RJ SETSTAK DYNAMIC - LT B0,B1,DYNAMIC-1 DYNAMIC SA1 RETURN DYNAMIC RJ UNPKBRR DYNAMIC SA1 STACK DYNAMIC SA2 LENGTH DYNAMIC SA3 DYNA DYNAMIC IX6 X1+X3 DYNAMIC SA6 A1 DYNAMIC IX6 X2-X3 DYNAMIC SA6 A2 DYNAMIC IX1 X0+X1 DYNAMIC SA2 B7 DYNAMIC BX3 X2 DYNAMIC AX3 60 DYNAMIC BX2 X2-X3 DYNAMIC BX3 X2 DYNAMIC DYN5 RJ STOREPA DYNAMIC ZR X0,DYN6 DYNAMIC SX6 1 DYNAMIC IX0 X0-X6 DYNAMIC IX1 X1-X6 DYNAMIC IX2 X2+X6 DYNAMIC SX6 X7 DYNAMIC SA6 X1 DYNAMIC AX7 18 DYNAMIC EQ DYN5 DYNAMIC DYNAMIC DYN6 SA4 EQUB DYNAMIC NZ X4,EQU1 DYNAMIC RJ PACKBRR DYNAMIC EQ DYNAMIC DYNAMIC DYNAMIC DYN7 RJ DYNAERR DYNAMIC - LT B0,B0,DYNAMIC-1 DYNAMIC DYNAMIC DYNA DATA 0 DYNAMIC DYNB DATA 0 DYNAMIC EQUATE TITLE SUBROUTINE EQUATE. DYNAMIC * SUBROUTINE EQUATE (A,N,I1,I2,I3) DYNAMIC DYNAMIC DYNAMIC VFD 42/0LEQUATE,18/5 DYNAMIC EQUATE PS 0 DYNAMIC + RJ KCCHECK DYNAMIC - LT B0,B0,EQUATE-1 DYNAMIC SA1 EQUATE DYNAMIC SA2 EQUATE-1 DYNAMIC BX6 X1 DYNAMIC BX7 X2 DYNAMIC SA6 DYNAMIC DYNAMIC SA7 DYNAMIC-1 DYNAMIC AX1 30 DYNAMIC SX6 B1 DYNAMIC SA6 EQUA DYNAMIC SX6 1 DYNAMIC SA6 EQUB DYNAMIC SB1 B2 DYNAMIC SB2 B3 DYNAMIC SB3 B4 DYNAMIC SB4 B5 DYNAMIC EQ DYN1 DYNAMIC DYNAMIC EQU1 SA1 EQUA DYNAMIC BX2 X1 DYNAMIC AX2 60 DYNAMIC BX1 X1-X2 DYNAMIC MX6 0 DYNAMIC SA6 EQUB DYNAMIC BX2 X3 DYNAMIC SA4 EQUC DYNAMIC BX6 X4 DYNAMIC SA6 DYNAMIC-1 DYNAMIC RJ STOREPA DYNAMIC RJ PACKBRR DYNAMIC EQ EQUATE DYNAMIC DYNAMIC EQUA DATA 0 DYNAMIC EQUB DATA 0 DYNAMIC EQUC VFD 42/0LDYNAMIC,18/4 DYNAMIC CONNECT TITLE SUBROUTINE CONNECT. DYNAMIC * SUBROUTINE CONNECT (K1,NP,SN,K2) DYNAMIC DYNAMIC DYNAMIC VFD 42/0LCONNECT,18/4 DYNAMIC CONNECT PS 0 DYNAMIC + RJ KCCHECK DYNAMIC - LT B0,B0,CONNECT-1 DYNAMIC SA1 RETURN DYNAMIC ZR X1,CON6 DYNAMIC CON1 SX1 X1-3 DYNAMIC ZR X1,CON6 DYNAMIC SA2 X1+RETURN DYNAMIC AX2 18 DYNAMIC SA2 X2 DYNAMIC SB5 X2+1 DYNAMIC NE B3,B5,CON1 DYNAMIC SX4 B1-377700B DYNAMIC PL X4,CON2 DYNAMIC SA4 B1 DYNAMIC CON2 ZR X4,CON6 DYNAMIC SX7 X4 DYNAMIC BX7 X7-X4 DYNAMIC NZ X7,CON6 DYNAMIC SA5 B4 DYNAMIC ZR X5,CON6 DYNAMIC SX7 X5 DYNAMIC BX7 X7-X5 DYNAMIC NZ X7,CON6 DYNAMIC SA3 B2 DYNAMIC SB7 X3 DYNAMIC LE B7,B0,CON6 DYNAMIC SX7 X3 DYNAMIC BX7 X7-X3 DYNAMIC NZ X7,CON6 DYNAMIC BX7 X4 DYNAMIC AX4 60 DYNAMIC BX4 X4-X7 DYNAMIC IX7 X4+X3 DYNAMIC SX7 X7-1 DYNAMIC SA2 CONNECT DYNAMIC AX2 30 DYNAMIC SA2 X2-1 DYNAMIC SX0 X2-1 DYNAMIC SA2 X2 DYNAMIC SX2 X2 DYNAMIC IX0 X0-X2 DYNAMIC SA0 X0 DYNAMIC IX2 X2-X7 DYNAMIC NG X2,CON6 DYNAMIC BX7 X5 DYNAMIC AX5 60 DYNAMIC BX5 X5-X7 DYNAMIC IX7 X3+X5 DYNAMIC SX7 X7-1 DYNAMIC SA2 B3-1 DYNAMIC SX0 A2-1 DYNAMIC SX2 X2 DYNAMIC IX6 X0-X2 DYNAMIC SB7 X6 DYNAMIC IX2 X2-X7 DYNAMIC NG X2,CON6 DYNAMIC BX7 X3 DYNAMIC SX0 X1+RETURN-2 DYNAMIC SA1 RETURN DYNAMIC RJ UNPKBRR DYNAMIC SX3 B7 DYNAMIC CON3 SB7 X5-6 DYNAMIC GT B7,B0,CON4 DYNAMIC SA1 X0 DYNAMIC SA2 A1+1 DYNAMIC SB7 X5 DYNAMIC JP B7+* DYNAMIC DYNAMIC + EQ CON5 DYNAMIC DYNAMIC + AX1 18 DYNAMIC EQ CON5 DYNAMIC DYNAMIC + AX1 36 DYNAMIC EQ CON5 DYNAMIC DYNAMIC + SX1 X2 DYNAMIC EQ CON5 DYNAMIC DYNAMIC + AX2 18 DYNAMIC SX1 X2 DYNAMIC EQ CON5 DYNAMIC DYNAMIC + AX2 36 DYNAMIC SX1 X2 DYNAMIC EQ CON5 DYNAMIC DYNAMIC CON4 IX2 X3+X5 DYNAMIC SA1 X2 DYNAMIC CON5 SX2 X4 DYNAMIC RJ STOREPA DYNAMIC SX4 X4+1 DYNAMIC SX5 X5+1 DYNAMIC SX7 X7-1 DYNAMIC NZ X7,CON3 DYNAMIC RJ PACKBRR DYNAMIC EQ CONNECT DYNAMIC DYNAMIC CON6 RJ DYNAERR DYNAMIC - LT B0,B0,CONNECT-1 DYNAMIC KLUDGE1 TITLE SUBROUTINE KLUDGE1. DYNAMIC * SUBROUTINE KLUDGE1 DYNAMIC DYNAMIC DYNAMIC VFD 42/0LKLUDGE1,18/0 DYNAMIC KLUDGE1 PS 0 DYNAMIC SA1 STACK DYNAMIC NZ X1,KLU1 DYNAMIC FLREAD STACK DYNAMIC KLU1 SA4 KLUDGE1 DYNAMIC AX4 30 DYNAMIC MX6 30 DYNAMIC SX2 X4-1 DYNAMIC SA4 X2 DYNAMIC BX6 -X6*X4 DYNAMIC SA5 KLUA DYNAMIC BX6 X5+X6 DYNAMIC SA6 A4 DYNAMIC SX4 X4 DYNAMIC SA5 X4 DYNAMIC SX0 X5 DYNAMIC IX5 X4-X5 DYNAMIC SA0 X5 DYNAMIC SA1 A1 DYNAMIC SA4 X4+1 DYNAMIC SA5 KLUB DYNAMIC BX6 X4+X5 DYNAMIC SA6 A4 DYNAMIC AX4 30 DYNAMIC SX3 X4 DYNAMIC SA4 RETURN DYNAMIC SX5 X4-3*N DYNAMIC ZR X5,KLU4 DYNAMIC SX6 X4+3 DYNAMIC SA6 RETURN DYNAMIC LX1 36 DYNAMIC LX2 18 DYNAMIC IX6 X1+X2 DYNAMIC IX6 X3+X6 DYNAMIC SA6 X4+RETURN+3 DYNAMIC SA4 X3-1 DYNAMIC MX7 54 DYNAMIC AX4 18 DYNAMIC BX7 -X7*X4 DYNAMIC SX2 X7 DYNAMIC IX6 X0-X2 DYNAMIC NG X6,KLU4 DYNAMIC KLU2 ZR X6,KLU3 DYNAMIC SX2 X2+1 DYNAMIC SX1 X2+377700B DYNAMIC RJ STOREPA DYNAMIC IX6 X0-X2 DYNAMIC EQ KLU2 DYNAMIC DYNAMIC KLU3 RJ PACKBRR DYNAMIC EQ KLUDGE1 DYNAMIC DYNAMIC KLU4 RJ DYNAERR DYNAMIC - LT B0,B0,KLUDGE1-1 DYNAMIC DYNAMIC KLUA VFD 6/04B,24/PACKBRR,30/0 DYNAMIC KLUB VFD 6/01B,24/0,6/02B,24/RELEASE DYNAMIC RSTSTAK TITLE SUBROUTINE RSTSTAK. DYNAMIC * SUBROUTINE RSTSTAK. DYNAMIC DYNAMIC DYNAMIC VFD 42/0LRSTSTAK,18/0 DYNAMIC RSTSTAK PS 0 DYNAMIC SA1 RETURN DYNAMIC SA1 X1+RETURN DYNAMIC NZ X1,RST1 DYNAMIC SA1 RETURN+3 DYNAMIC ZR X1,RSTSTAK DYNAMIC RST1 AX1 36 DYNAMIC SX6 X1+77B DYNAMIC AX6 6 DYNAMIC LX6 36 DYNAMIC SA6 FLDLEN DYNAMIC AX6 30 DYNAMIC IX6 X6-X1 DYNAMIC SA6 LENGTH DYNAMIC SX6 X1 DYNAMIC SA6 STACK DYNAMIC RJ MEMORY DYNAMIC EQ RSTSTAK DYNAMIC SETSTAK TITLE SUBROUTINE SETSTAK. DYNAMIC * SUBROUTINE SETSTAK (N) DYNAMIC DYNAMIC DYNAMIC VFD 42/0LSETSTAK,18/1 DYNAMIC SETSTAK PS 0 DYNAMIC SA1 LENGTH DYNAMIC SA2 B1 DYNAMIC IX3 X2-X1 DYNAMIC NG X3,SETSTAK DYNAMIC ZR X3,SETSTAK DYNAMIC SA3 STACK DYNAMIC NZ X3,SET1 DYNAMIC FLREAD STACK DYNAMIC SET1 RELREAD ACTW+4 DYNAMIC SA3 STACK DYNAMIC AX6 48 DYNAMIC IX4 X2+X3 DYNAMIC LX6 6 DYNAMIC IX6 X6-X4 DYNAMIC NG X6,SET2 DYNAMIC SX6 X4+77B DYNAMIC AX6 6 DYNAMIC LX6 36 DYNAMIC SA6 FLDLEN DYNAMIC AX6 30 DYNAMIC IX6 X6-X3 DYNAMIC SA6 LENGTH DYNAMIC RJ MEMORY DYNAMIC EQ SETSTAK DYNAMIC DYNAMIC SET2 SX1 500 DYNAMIC SX2 =C* MEMORY REQUEST EXCEEDS ACCOUNT MAXIMUM.* DYNAMIC + RJ =XSYSTEM DYNAMIC - LT B0,B0,SETSTAK-1 DYNAMIC + RJ =XABNORML DYNAMIC - LT B0,B0,SETSTAK-1 DYNAMIC TITLE SUBROUTINES DOUBLE AND COMPLEX. DYNAMIC * SUBROUTINE DOUBLE (A) DYNAMIC * SUBROUTINE COMPLEX (A) DYNAMIC DYNAMIC DYNAMIC DOUBLE PS 0 DYNAMIC COMPLEX EQU DOUBLE DYNAMIC SB7 377700B DYNAMIC SX6 B7-B1 DYNAMIC NG X6,DOUBLE DYNAMIC SA1 B1 DYNAMIC BX6 -X1 DYNAMIC EQ DOUBLE DYNAMIC TITLE SUBROUTINE DYNASET. DYNAMIC * SUBROUTINE DYNASET(B,E) DYNAMIC DYNAMIC DYNAMIC DYNASET PS 0 DYNAMIC SX6 B1 DYNAMIC SA6 STACK DYNAMIC SX6 B2-B1 DYNAMIC SX6 X6+1 DYNAMIC SA6 LENGTH DYNAMIC EQ DYNASET DYNAMIC TITLE SUBROUTINES. DYNAMIC * ERROR ROUTINE. DYNAMIC DYNAMIC DYNAMIC VFD 42/0LDYNAERR,18/0 DYNAMIC DYNAERR PS 0 DYNAMIC SX1 500 DYNAMIC SX2 =C* SUBROUTINE DYNAMIC USAGE ERROR.* DYNAMIC + RJ =XSYSTEM DYNAMIC - LT B0,B0,DYNAERR-1 DYNAMIC + RJ =XABNORML DYNAMIC - LT B0,B0,DYNAERR-1 DYNAMIC SPACE 4 DYNAMIC * KLUDGE1 CALL CHECK ROUTINE. DYNAMIC DYNAMIC DYNAMIC VFD 42/0LKCCHECK,18/0 DYNAMIC KCCHECK PS 0 DYNAMIC SA1 KCCHECK DYNAMIC AX1 30 DYNAMIC SA1 X1-2 DYNAMIC AX1 30 DYNAMIC SA1 X1-1 DYNAMIC SA1 X1+1 DYNAMIC SX1 X1 DYNAMIC NZ X1,KCCHECK DYNAMIC + RJ DYNAERR DYNAMIC - LT B0,B0,KCCHECK-1 DYNAMIC SPACE 4 DYNAMIC * MEMORY ROUTINE. DYNAMIC DYNAMIC DYNAMIC MEMORY PS 0 DYNAMIC SA4 1 DYNAMIC NZ X4,* DYNAMIC SA5 MEMA DYNAMIC BX6 X5 DYNAMIC SA6 A4 DYNAMIC SA4 1 DYNAMIC NZ X4,* DYNAMIC EQ MEMORY DYNAMIC DYNAMIC MEMA VFD 18/0LMEM,6/20B,18/,18/FLDLEN DYNAMIC SPACE 4 DYNAMIC * PACK B-REGISTERS ROUTINE. DYNAMIC DYNAMIC DYNAMIC PACKBRR PS 0 DYNAMIC SX1 B1 DYNAMIC SX2 B2 DYNAMIC SX3 B3 DYNAMIC LX2 18 DYNAMIC LX3 36 DYNAMIC IX6 X1+X2 DYNAMIC IX6 X3+X6 DYNAMIC SX1 B4 DYNAMIC SX2 B5 DYNAMIC SX3 B6 DYNAMIC LX2 18 DYNAMIC LX3 36 DYNAMIC IX7 X1+X2 DYNAMIC IX7 X3+X7 DYNAMIC SA1 RETURN DYNAMIC SA6 X1+RETURN-2 DYNAMIC SA7 X1+RETURN-1 DYNAMIC SA1 X1+RETURN DYNAMIC AX1 18 DYNAMIC SA1 X1 DYNAMIC SB7 X1+2 DYNAMIC JP B7 DYNAMIC SPACE 4 DYNAMIC * RELEASE STORAGE ROUTINE. DYNAMIC DYNAMIC DYNAMIC RELEASE SA1 RETURN DYNAMIC SA2 X1+RETURN DYNAMIC BX3 X6 DYNAMIC SX6 X1-3 DYNAMIC SA6 A1 DYNAMIC SB7 X2 DYNAMIC AX2 18 DYNAMIC SA4 X2 DYNAMIC MX6 30 DYNAMIC BX6 -X6*X4 DYNAMIC SA4 RELA DYNAMIC BX6 X4+X6 DYNAMIC SA6 X2 DYNAMIC AX2 18 DYNAMIC SA4 STACK DYNAMIC SX6 X2 DYNAMIC SA6 A4 DYNAMIC SA5 LENGTH DYNAMIC IX6 X4-X6 DYNAMIC IX6 X5+X6 DYNAMIC SA6 A5 DYNAMIC BX6 X3 DYNAMIC JP B7 DYNAMIC DYNAMIC RELA VFD 6/01B,24/KLUDGE1,30/0 DYNAMIC SPACE 4 DYNAMIC * STORE PARAMETER ADDRESS ROUTINE. DYNAMIC DYNAMIC DYNAMIC STO1 SB7 B7+6 DYNAMIC SX6 X1 DYNAMIC SA6 A0+B7 DYNAMIC DYNAMIC STOREPA PS 0 DYNAMIC SB7 X2-6 DYNAMIC GT B7,B0,STO1 DYNAMIC SB7 X2 DYNAMIC JP B7+* DYNAMIC DYNAMIC SB1 X1+0 DYNAMIC EQ STOREPA DYNAMIC DYNAMIC SB2 X1+0 DYNAMIC EQ STOREPA DYNAMIC DYNAMIC SB3 X1+0 DYNAMIC EQ STOREPA DYNAMIC DYNAMIC SB4 X1+0 DYNAMIC EQ STOREPA DYNAMIC DYNAMIC SB5 X1+0 DYNAMIC EQ STOREPA DYNAMIC DYNAMIC SB6 X1+0 DYNAMIC EQ STOREPA DYNAMIC SPACE 4 DYNAMIC * UNPACK B-REGISTERS ROUTINE. DYNAMIC DYNAMIC DYNAMIC UNPKBRR PS 0 DYNAMIC SA2 X1+RETURN-2 DYNAMIC SA3 X1+RETURN-1 DYNAMIC SB1 X2 DYNAMIC AX2 18 DYNAMIC SB2 X2 DYNAMIC AX2 18 DYNAMIC SB3 X2 DYNAMIC SB4 X3 DYNAMIC AX3 18 DYNAMIC SB5 X3 DYNAMIC AX3 18 DYNAMIC SB6 X3 DYNAMIC EQ UNPKBRR DYNAMIC TITLE STORAGE ASSIGNMENTS. DYNAMIC USE /DYNACOM/ DYNAMIC LENGTH DATA 0 DYNAMIC STACK DATA 0 DYNAMIC FLDLEN DATA 0 DYNAMIC RETURN BSSZ 3*N+1 DYNAMIC USE DYNAMIC SPACE 3 DYNAMIC END DYNAMIC IDENT ARITH1 ARITH1 *** ARITH1 - ARITHMETIC PACKAGE FOR LINEQ1 AND DTMNT1. ARITH1 * ARITH1 * DAVID S. DODSON. 06/01/70. ARITH1 * RUNLIB3 * ADAPTED FOR FTN BY DAVID A SEAMAN. 6/30/78 RUNLIB3 ARITH1 ARITH1 *** FUNCTION. ARITH1 * ARITH1 * GIVEN REAL SCALAR C AND N-VECTORS A AND B, THIS ARITH1 * PACKAGE COMPUTES THE FUNCTION: ARITH1 * N ARITH1 * --- ARITH1 * ARITH1 = C - > A(I) * B(I) ARITH1 * --- ARITH1 * I=1 ARITH1 ARITH1 ARITH1 *** USAGE. ARITH1 * ARITH1 * FORTRAN FUNCTION REFERENCE TO ARITH1 OF FORM: ARITH1 * ARITH1 * Y=ARITH1(C,N,A,KA,B,KB) ARITH1 * ARITH1 * WHERE: A AND B ARE THE NAMES OF THE TWO VECTORS AND ARITH1 * KA AND KB ARE THE INCREMENTS BETWEEN SUCCESSIVE ARITH1 * ELEMENTS OF THE A AND B VECTORS IN MEMORY. ARITH1 ARITH1 ARITH1 *** COMPATABILITY. ARITH1 * ARITH1 * THIS ROUTINE IS EQUIVALENT TO THE FORTRAN SUBPROGRAM: ARITH1 * ARITH1 * FUNCTION ARITH1 (C,N,A,KA,B,KB) ARITH1 * DOUBLE PRECISION T ARITH1 * REAL A(KA,N),B(KB,N) ARITH1 * T=DBLE(C) ARITH1 * IF(N.EQ.0)GO TO 5 ARITH1 * DO 4 I=1,N ARITH1 * 4 T=T-DBLE(A(1,I))*DBLE(B(1,I)) ARITH1 * 5 ARITH1=T ARITH1 * RETURN ARITH1 * END ARITH1 EJECT ARITH1 ENTRY ARITH1 ARITH1 ARITH1 ARITH1 LOOP SA1 B3 FETCH NEXT A ARITH1 SB3 B3+B4 ARITH1 SA2 B5 FETCH NEXT B ARITH1 SB5 B5+B6 ARITH1 FX0 X1*X2 (X0,X1) = (X1) * (X2) ARITH1 DX1 X1*X2 ARITH1 FX2 X6-X0 (X6,X7) = (X6,X7) - (X0,X1) ARITH1 DX3 X6-X0 ARITH1 FX0 X7-X1 ARITH1 NX2 X2 ARITH1 FX1 X0+X3 ARITH1 FX0 X1+X2 ARITH1 NX3 X0 ARITH1 DX1 X1+X2 ARITH1 NX2 X1 ARITH1 FX6 X2+X3 ARITH1 DX7 X2+X3 ARITH1 SB2 B2-B1 COUNT TERM ARITH1 NZ B2,LOOP LOOP TO COMPUTE INNER PRODUCT ARITH1 ARITH1 ARITH1 BSSZ 1 ENTRY/EXIT ARITH1 ERRZR *F CALLING SEQUENCE MUST BE SPECIFIED RUNLIB3 IFEQ *F,1 IF *F = 1 USE RUN CALLING SEQUENCE RUNLIB3 SA1 B1 (X6,X7) = DBLE(C) ARITH1 BX6 X1 ARITH1 MX7 0 ARITH1 DX7 X6+X7 ARITH1 SB1 1 (B1) = 1 ARITH1 SA1 B2 (B2) = N ARITH1 SB2 X1 ARITH1 ZR X1,ARITH1 RETURN IF N = 0 ARITH1 SA1 B4 (B4) = KA ARITH1 SB4 X1 ARITH1 SA1 B6 (B6) = KB ARITH1 SB6 X1 ARITH1 EQ LOOP ARITH1 ENDIF RUNLIB3 IFEQ *F,2 IF *F = 2 USE FTN CALLING SEQUENCE RUNLIB3 SB1 1 (B1) = 1 RUNLIB3 SA2 X1 (X6,X7) = DBLE(C) RUNLIB3 BX6 X2 RUNLIB3 MX7 0 RUNLIB3 SA1 A1+B1 (B2) = N RUNLIB3 SA2 X1 RUNLIB3 ZR X2,ARITH1 RETURN IF N = 0 RUNLIB3 SB2 X2 RUNLIB3 SA1 A1+B1 (B3) = A RUNLIB3 SB3 X1 RUNLIB3 SA1 A1+B1 (B4) = (KA) RUNLIB3 SA2 X1 RUNLIB3 SB4 X2 RUNLIB3 SA1 A1+B1 (B5) = B RUNLIB3 SB5 X1 RUNLIB3 SA1 A1+B1 (B6) = (KB) RUNLIB3 SA2 X1 RUNLIB3 SB6 X2 RUNLIB3 EQ LOOP RUNLIB3 ENDIF RUNLIB3 SPACE 4 ARITH1 END ARITH1