$ID C-0001 UNRUH, DENNIS 2515-10003 $JOB UNRUH, DENNIS 2515-10003 $EXECUTE IBJOB $IBJOB TPBV MAP,DECK $IBFTC TPBV DECK C TWO POINT BOUNDARY VALUE PROBLEM TPBV0005 C TPBV0006 C PERROR IS A NUMBER WHICH WHEN MULTIPLIED BY 100 EQUALS THE TPBV0007 C MAXIMUM ALLOWABLE PERCENT ERROR TPBV0008 C TPBV0009 C CONV IS THE CONVERGENCE FACTOR. IT SHOULD BE SOME NUMBER TPBV0010 C .GT. ZERO AND .LE. 1.0 TPBV0011 C TPBV0012 C M NUMBER OF STATE VARIABLES FOR WHICH THE INITIAL CONDITIONS TPBV0013 C ARE KNOWN TPBV0014 C TPBV0015 C MM(I) THE SUBSCRIPTS OF THE STATE VARIABLES FOR WHICH THE TPBV0016 C FINAL TIME BOUNDARY CONDITIONS ARE KNOWN TPBV0017 C TPBV0018 C NSTOR NUMBER OF POINTS AT WHICH STATE VECTOR IS STORED. IT TPBV0019 C SHOULD BE NOTED THAT NSTOR IS EQUAL TO THE FINAL TIME/TRYSTP + 1 TPBV0020 C TPBV0021 C TRYSTP STEP SIZE FOR INTEGRATION TPBV0022 C NSYS ORDER OF SYSTEM TPBV0023 C NWRITE IS THE NUMBER OF TIME STEPS BETWEEN WRITING STATE VARIABLE TPBV0024 C FBC(I) DESIRED FINAL BOUNDARY CONDITIONS TPBV0025 C TPBV0026 C COMMON Y(2*NSYS*(NSYS-M+1)+2) TPBV0027 COMMON Y(442) TPBV0028 C COMMON /OPCON/ X(NSYS),U(NC),XDEL(NSYS),UDEL(NC),C(NSYS),CU(NSYS) TPBV0029 C 1MM(NSYS-M),FBC(NSYS-M),GX(NSYS,NSYS),XDIF(NSYS),UDIF(NC) TPBV0030 C 2AA(NSYS,NSYS),B(NSYS,NSYS),F(NSYS),G(NC) TPBV0031 COMMON /OPCON/ X(20),U(20),XDEL(20),UDEL(20),C(20),CU(20), TPBV0032 1MM(20),FBC(20),GX(20,20),XDIF(20),UDIF(20), TPBV0033 2AA(20,20),B(20,20),F(20),G(20) TPBV0034 COMMON /OPCONA/ ML,N3,NSYS,NC,N1,N TPBV0035 C COMMON /STOR/ XS(NSYS,NSTOR),US(NC,NSTOR) TPBV0036 COMMON /STOR/ XS(20,301),US(20,301) TPBV0037 EQUIVALENCE (GU(1,1),B(1,1)) TPBV0038 C DIMENSION GU(NSYS,NSYS),UN(NC) TPBV0039 DIMENSION GU(20,20),UN(20) TPBV0040 101 FORMAT (5I10,3F10.5) TPBV0041 102 FORMAT (4(I10,F10.5)) TPBV0042 103 FORMAT (4(I3,2X,I3,2X,E10.3)) TPBV0043 104 FORMAT (6(2X,E10.3)) TPBV0044 105 FORMAT (8I10) TPBV0045 106 FORMAT (55H PARTICULAR AND HOMOGENEOUS SOLUTIONS. ITERATION NUMBERTPBV0046 1,I5) TPBV0047 107 FORMAT (43H FINAL PARTICULAR SOLUTION ITERATION NUMBER,I5) TPBV0048 108 FORMAT (24H DETERMINANT EQUALS ZERO) TPBV0049 109 FORMAT (49H PROBLEM HAS CONVERGED WITHIN ERROR SPECIFICATION) TPBV0050 110 FORMAT (39H STARTING SOLUTION FOR X IS GIVEN BELOW) TPBV0051 111 FORMAT (29H THE WRITE STATEMENT USED WAS) TPBV0052 112 FORMAT (49H WRITE (6,103) ((I,J,XS(I,J),J=1,NSTOR),I=1,NSYS)) TPBV0053 113 FORMAT (39H STARTING SOLUTION FOR U IS GIVEN BELOW) TPBV0054 114 FORMAT (29H THE WRITE STATEMENT USED WAS) TPBV0055 115 FORMAT (47H WRITE (6,103) ((I,J,US(I,J),J=1,NSTOR),I=1,NC)) TPBV0056 116 FORMAT (30X,7H TIME =,E10.5) TPBV0057 117 FORMAT (20H PARTICULAR SOLUTION) TPBV0058 118 FORMAT (21H HOMOGENEOUS SOLUTION,I5) TPBV0059 119 FORMAT (20H ALGEBRAIC VARIABLES) TPBV0060 120 FORMAT (80H ......................................................TPBV0061 1.........................) TPBV0062 READ (5,101) NSYS,NC,M,NSTOR,NWRITE,TRYSTP,CONV,PERROR TPBV0063 WRITE(6,101) NSYS,NC,M,NSTOR,NWRITE,TRYSTP,CONV,PERROR TPBV0064 N1=NSYS-M TPBV0065 READ (5,102) (MM(I),FBC(I),I=1,N1) TPBV0066 WRITE(6,102) (MM(I),FBC(I),I=1,N1) TPBV0067 CALL STORE (NSTOR,TRYSTP) TPBV0068 WRITE (6,110) TPBV0069 WRITE (6,111) TPBV0070 WRITE (6,112) TPBV0071 WRITE (6,103) ((I,J,XS(I,J),J=1,NSTOR),I=1,NSYS) TPBV0072 IF (NC.EQ.0) GO TO 342 TPBV0073 WRITE (6,113) TPBV0074 WRITE (6,114) TPBV0075 WRITE (6,115) TPBV0076 WRITE (6,103) ((I,J,US(I,J),J=1,NSTOR),I=1,NC) TPBV0077 342 ITER=1 TPBV0078 C.......................................................................TPBV0079 C FIRST PARTICULAR SOLUTION AND SET OF HOMOGENEOUS SOLUTIONS TPBV0080 C.......................................................................TPBV0081 3 ML=1 TPBV0082 NSTEP=NWRITE TPBV0083 N=(N1+1)*NSYS TPBV0084 N2=N+1 TPBV0085 N3=N+2 TPBV0086 N4=N1+1 TPBV0087 WRITE (6,120) TPBV0088 WRITE (6,106) ITER TPBV0089 WRITE (6,120) TPBV0090 C TPBV0091 C SET INITIAL CONDITIONS AND INITIAL TIME TPBV0092 C TPBV0093 DO 4 I=1,N2 TPBV0094 4 Y(I)=0.0 TPBV0095 DO 5 I=1,NSYS TPBV0096 5 Y(I)=XS(I,1) TPBV0097 DO 6 I=1,N1 TPBV0098 II=(I+1)*NSYS-N1+I TPBV0099 6 Y(II)=1.0 TPBV0100 C TPBV0101 C WRITE INITIAL CONDITIONS AND INITIAL TIME TPBV0102 C TPBV0103 WRITE (6,116) Y(N2) TPBV0104 DO 327 I=1,N4 TPBV0105 DO 328 J=1,NSYS TPBV0106 II=(I-1)*NSYS +J TPBV0107 III=I-1 TPBV0108 328 X(J)=Y(II) TPBV0109 IF (III.EQ.0) GO TO 329 TPBV0110 WRITE (6,118) III TPBV0111 GO TO 327 TPBV0112 329 WRITE (6,117) TPBV0113 327 WRITE (6,104) (X(K),K=1,NSYS) TPBV0114 NFIN=NSTOR-1 TPBV0115 C TPBV0116 C INTEGRATION IS NOW DONE STEP BY STEP TPBV0117 C TPBV0118 DO 8 I=1,NFIN TPBV0119 C TPBV0120 C SETTING C(I) EQUAL TO STORED SOLUTION OF X(I) TPBV0121 C SETTING CU(I) EQUAL TO STORED SOLUTION OF U(I) TPBV0122 C TPBV0123 L=I TPBV0124 DO 9 J=1,NSYS TPBV0125 C(J)=XS(J,L) TPBV0126 9 XDEL(J)=XS(J,L+1)-XS(J,L) TPBV0127 IF (NC.EQ.0) GO TO 319 TPBV0128 DO 302 J=1,NC TPBV0129 CU(J)=US(J,L) TPBV0130 302 UDEL(J)=US(J,L+1)-US(J,L) TPBV0131 319 CALL KAMSUB (L,N,TRYSTP) TPBV0132 IF (I.NE.NSTEP) GO TO 8 TPBV0133 C TPBV0134 C WRITE STATE VARIABLE AFTER EVERY NWRITE STEPS OF INTEGRATION TPBV0135 C TPBV0136 WRITE (6,116) Y(N2) TPBV0137 DO 331 JJ=1,N4 TPBV0138 DO 332 J=1,NSYS TPBV0139 III=JJ-1 TPBV0140 II=III*NSYS+J TPBV0141 332 X(J)=Y(II) TPBV0142 IF (III.EQ.0) GO TO 333 TPBV0143 WRITE (6,118) III TPBV0144 GO TO 331 TPBV0145 333 WRITE (6,117) TPBV0146 331 WRITE (6,104) (X(K),K=1,NSYS) TPBV0147 NSTEP =NSTEP+NWRITE TPBV0148 8 CONTINUE TPBV0149 C TPBV0150 C WRITE STATE VARIABLE AT FINAL TIME TPBV0151 C TPBV0152 WRITE (6,116) Y(N2) TPBV0153 DO 335 I=1,N4 TPBV0154 DO 336 J=1,NSYS TPBV0155 III=I-1 TPBV0156 II=III*NSYS+J TPBV0157 336 X(J)=Y(II) TPBV0158 IF (III.EQ.0) GO TO 337 TPBV0159 WRITE (6,118) III TPBV0160 GO TO 335 TPBV0161 337 WRITE (6,117) TPBV0162 335 WRITE (6,104) (X(K),K=1,NSYS) TPBV0163 C.......................................................................TPBV0164 C DETERMINING INITIAL CONDITIONS FOR THE FINAL PARTICULAR SOLUTION TPBV0165 C.......................................................................TPBV0166 DO 10 I=1,N1 TPBV0167 DO 10 J=1,N1 TPBV0168 II=MM(I)+J*NSYS TPBV0169 10 B(I,J)=Y(II) TPBV0170 CALL ARRAY (2,N1,N1,20,20) TPBV0171 CALL MINV (N1,D) TPBV0172 IF (D.EQ.0.0) GO TO 21 TPBV0173 CALL ARRAY (1,N1,N1,20,20) TPBV0174 DO 11 I=1,N1 TPBV0175 II=MM(I) TPBV0176 11 C(I)=FBC(I)-Y(II) TPBV0177 DO 12 I=1,N1 TPBV0178 II=M+I TPBV0179 12 Y(II)=0.0 TPBV0180 DO 13 I=1,N1 TPBV0181 DO 13 J=1,N1 TPBV0182 II=M+I TPBV0183 13 Y(II)=B(I,J)*C(J)+Y(II) TPBV0184 DO 300 I=1,N1 TPBV0185 II=M+I TPBV0186 300 Y(II)=Y(II)+XS(II,1) TPBV0187 DO 14 I=1,M TPBV0188 14 Y(I)=XS(I,1) TPBV0189 C.......................................................................TPBV0190 C FINAL PARTICULAR SOLUTION TPBV0191 C.......................................................................TPBV0192 NSTEP=NWRITE TPBV0193 ML=2 TPBV0194 N=NSYS TPBV0195 N2=N+1 TPBV0196 N3=N+2 TPBV0197 Y(N2)=0.0 TPBV0198 WRITE (6,120) TPBV0199 WRITE (6,107) ITER TPBV0200 WRITE (6,120) TPBV0201 IF (NC.EQ.0) GO TO 320 TPBV0202 C TPBV0203 C CALCULATE NEW VALUE FOR U(I) AT THE INITIAL TIME TPBV0204 C TPBV0205 X(NSYS+1)=0.0 TPBV0206 DO 307 I=1,NSYS TPBV0207 307 X(I)=XS(I,1) TPBV0208 DO 308 I=1,NC TPBV0209 308 U(I)=US(I,1) TPBV0210 CALL JABGU TPBV0211 CALL EQG TPBV0212 CALL JABGX TPBV0213 DO 306 J=1,NSYS TPBV0214 DO 306 I=1,NC TPBV0215 AA(I,J)=0.0 TPBV0216 DO 306 K=1,NC TPBV0217 306 AA(I,J)=AA(I,J)+GU(I,K)*GX(K,J) TPBV0218 DO 310 I=1,NSYS TPBV0219 310 XDIF(I)=Y(I)-X(I) TPBV0220 DO 309 I=1,NC TPBV0221 UDIF(I)=0.0 TPBV0222 DO 309 K=1,NSYS TPBV0223 309 UDIF(I)=UDIF(I)-AA(I,K)*XDIF(K) TPBV0224 DO 311 I=1,NC TPBV0225 DO 311 K=1,NC TPBV0226 311 UDIF(I)=UDIF(I)-GU(I,K)*G(K) TPBV0227 DO 315 I=1,NC TPBV0228 315 UN(I)=US(I,1)+UDIF(I) TPBV0229 C TPBV0230 C WRITE THE NEW VALUES FOR X(I) AND U(I) AT THE INITIAL TIME TPBV0231 C TPBV0232 320 WRITE (6,116) Y(N2) TPBV0233 IF (NC.EQ.0) GO TO 339 TPBV0234 WRITE (6,117) TPBV0235 339 WRITE (6,104) (Y(I),I=1,NSYS) TPBV0236 IF (NC.EQ.0) GO TO 321 TPBV0237 WRITE (6,119) TPBV0238 WRITE (6,104) (UN(I),I=1,NC) TPBV0239 321 IERROR =1 TPBV0240 322 NFIN=NSTOR-1 TPBV0241 C TPBV0242 C INTEGRATION IS NOW DONE STEP BY STEP TPBV0243 C TPBV0244 DO 17 I=1,NFIN TPBV0245 C TPBV0246 C SETTING C(I) EQUAL TO STORED SOLUTION OF X(I) TPBV0247 C SETTING CU(I) EQUAL TO STORED SOLUTION OF U(I) TPBV0248 C TPBV0249 L=I TPBV0250 DO 18 J=1,NSYS TPBV0251 C(J)=XS(J,L) TPBV0252 18 XDEL(J)=XS(J,L+1)-XS(J,L) TPBV0253 IF (NC.EQ.0) GO TO 323 TPBV0254 DO 304 J=1,NC TPBV0255 CU(J)=US(J,L) TPBV0256 304 UDEL(J)=US(J,L+1)-US(J,L) TPBV0257 C TPBV0258 C CHECK PERCENT ERROR TPBV0259 C NEXT STARTING SOLUTION IS ALSO STORED TPBV0260 C TPBV0261 323 DO 19 J=1,NSYS TPBV0262 IF (IERROR.EQ.2) GO TO 317 TPBV0263 DEN=ABS(Y(J))+ABS(XS(J,L)) TPBV0264 IF (DEN.EQ.0.0) GO TO 317 TPBV0265 ERROR=ABS((Y(J)-XS(J,L))/DEN) TPBV0266 IF (ERROR.GT.PERROR) IERROR=2 TPBV0267 317 IF (NC.EQ.0) GO TO 19 TPBV0268 US(J,L)=(1.0-CONV)*US(J,L)+CONV*UN(J) TPBV0269 19 XS(J,L)=(1.0-CONV)*XS(J,L)+CONV*Y(J) TPBV0270 CALL KAMSUB (L,N,TRYSTP) TPBV0271 IF (NC.EQ.0) GO TO 324 TPBV0272 C TPBV0273 C CALCULATE THE NEW VALUE OF U(I) AT TIME=L*TRYSTP TPBV0274 C TPBV0275 CALL JABGU TPBV0276 CALL EQG TPBV0277 CALL JABGX TPBV0278 DO 350 J=1,NSYS TPBV0279 DO 350 KK=1,NC TPBV0280 AA(KK,J)=0.0 TPBV0281 DO 350 K=1,NC TPBV0282 350 AA(KK,J)=AA(KK,J)+GU(KK,K)*GX(K,J) TPBV0283 DO 351 J=1,NSYS TPBV0284 351 XDIF(J)=Y(J)-X(J) TPBV0285 DO 352 J=1,NC TPBV0286 UDIF(J)=0.0 TPBV0287 DO 352 K=1,NSYS TPBV0288 352 UDIF(J)=UDIF(J)-AA(J,K)*XDIF(K) TPBV0289 DO 353 J=1,NC TPBV0290 DO 353 K=1,NC TPBV0291 353 UDIF(J)=UDIF(J)-GU(J,K)*G(K) TPBV0292 DO 354 J=1,NC TPBV0293 354 UN(J)=US(J,L+1)+UDIF(J) TPBV0294 324 IF (I.NE.NSTEP) GO TO 17 TPBV0295 C TPBV0296 C WRITE NEW VALUES OF X(I) AND U(I) AFTER NWRITE STEPS OF TPBV0297 C INTEGRATION TPBV0298 C TPBV0299 WRITE (6,116) Y(N2) TPBV0300 IF (NC.EQ.0) GO TO 340 TPBV0301 WRITE (6,117) TPBV0302 340 WRITE (6,104) (Y(J),J=1,NSYS) TPBV0303 IF (NC.EQ.0) GO TO 325 TPBV0304 WRITE (6,119) TPBV0305 WRITE (6,104) (UN(J),J=1,NC) TPBV0306 325 NSTEP=NSTEP+NWRITE TPBV0307 17 CONTINUE TPBV0308 C TPBV0309 C WRITE NEW VALUES OF X(I) AND U(I) AT FINAL TIME TPBV0310 C TPBV0311 WRITE (6,116) Y(N2) TPBV0312 IF (NC.EQ.0) GO TO 341 TPBV0313 WRITE (6,117) TPBV0314 341 WRITE (6,104) (Y(J),J=1,NSYS) TPBV0315 IF (NC.EQ.0) GO TO 326 TPBV0316 WRITE (6,119) TPBV0317 WRITE (6,104) (UN(J),J=1,NC) TPBV0318 C TPBV0319 C STORE NEW STARTING SOLUTION TPBV0320 C TPBV0321 DO 305 I=1,NC TPBV0322 305 US(I,NSTOR)=(1.0-CONV)*US(I,NSTOR)+CONV*UN(I) TPBV0323 326 DO 20 I=1,NSYS TPBV0324 20 XS(I,NSTOR)=(1.0-CONV)*XS(I,NSTOR)+CONV*Y(I) TPBV0325 ITER =ITER+1 TPBV0326 CONV=2.0*CONV TPBV0327 IF (CONV.GT.1.0) CONV=1.0 TPBV0328 IF(IERROR.EQ.2) GO TO 3 TPBV0329 WRITE (6,109) TPBV0330 GO TO 22 TPBV0331 21 CONTINUE TPBV0332 WRITE (6,108) TPBV0333 22 CONTINUE TPBV0334 END TPBV0335 $IBFTC DERFUX DECK SUBROUTINE DERFUN DERF0002 C COMMON Y(2*NSYS*(NSYS-M+1)+2) DERF0003 COMMON Y(442) DERF0004 COMMON /DER/ STIME DERF0005 C COMMON /OPCON/ X(NSYS),U(NC),XDEL(NSYS),UDEL(NC),C(NSYS),CU(NSYS) DERF0006 C 1MM(NSYS-M),FBC(NSYS-M),GX(NSYS,NSYS),XDIF(NSYS),UDIF(NC) DERF0007 C 2AA(NSYS,NSYS),B(NSYS,NSYS),F(NSYS),G(NC) DERF0008 COMMON /OPCON/ X(20),U(20),XDEL(20),UDEL(20),C(20),CU(20), DERF0009 1MM(20),FBC(20),GX(20,20),XDIF(20),UDIF(20), DERF0010 2AA(20,20),B(20,20),F(20),G(20) DERF0011 COMMON /OPCONA/ ML,N3,NSYS,NC,N1,N DERF0012 C DIMENSION GU(NSYS,NSYS),FU(NSYS,NSYS),FX(NSYS,NSYS) DERF0013 DIMENSION GU(20,20),FU(20,20),FX(20,20) DERF0014 EQUIVALENCE (GU(1,1),B(1,1)) DERF0015 EQUIVALENCE (FU(1,1),GX(1,1)) DERF0016 EQUIVALENCE (FX(1,1),GX(1,1)) DERF0017 C DERF0018 C SUBROUTINES KAMSUB AND DERFUN ARE BASICALLY THE NUMERICAL DERF0019 C INTEGRATION PROGRAM WHICH IS AVAILABLE FROM THE MECHANICAL DERF0020 C ENGINEERING DEPARTMENT OF OKLAHOMA STATE UNIVERSITY DERF0021 C DERF0022 C NO INFORMATION IS REQUIRED IN THIS SUBPROGRAM DERF0023 C DERF0024 X(NSYS+1)=Y(N+1) DERF0025 DO 12 I=1,NSYS DERF0026 12 X(I)=C(I)+STIME*XDEL(I) DERF0027 DO 2 I=1,NSYS DERF0028 2 XDIF(I)=Y(I)-X(I) DERF0029 IF (NC.EQ.0) GO TO 18 DERF0030 DO 13 I=1,NC DERF0031 13 U(I)=CU(I)+STIME*UDEL(I) DERF0032 CALL JABGU DERF0033 CALL JABGX DERF0034 DO 1 J=1,NSYS DERF0035 DO 1 I=1,NC DERF0036 AA(I,J)=0.0 DERF0037 DO 1 K=1,NC DERF0038 1 AA(I,J)=AA(I,J)+GU(I,K)*GX(K,J) DERF0039 CALL EQG DERF0040 CALL JABFU DERF0041 DO 14 I=1,NC DERF0042 F(I)=0.0 DERF0043 DO 14 K=1,NC DERF0044 14 F(I)=F(I)+GU(I,K)*G(K) DERF0045 DO 15 I=1,NSYS DERF0046 G(I) =0.0 DERF0047 DO 15 K=1,NC DERF0048 15 G(I)=G(I)+FU(I,K)*F(K) DERF0049 18 CALL EQUA DERF0050 IF (NC.EQ.0) GO TO 19 DERF0051 DO 16 I=1,NSYS DERF0052 16 F(I)=F(I)-G(I) DERF0053 DO 5 J=1,NSYS DERF0054 DO 5 I=1,NSYS DERF0055 B(I,J)=0.0 DERF0056 DO 5 K=1,NC DERF0057 5 B(I,J)=B(I,J)+FU(I,K)*AA(K,J) DERF0058 19 CALL JABFX DERF0059 IF (NC.EQ.0) GO TO 20 DERF0060 DO 6 I=1,NSYS DERF0061 DO 6 J=1,NSYS DERF0062 6 AA(I,J)=FX(I,J)-B(I,J) DERF0063 GO TO 21 DERF0064 20 DO 22 I=1,NSYS DERF0065 DO 22 J=1,NSYS DERF0066 22 AA(I,J)=FX(I,J) DERF0067 C DERF0068 C THE PARTICULAR DIFFERENTIAL EQUATIONS ARE GENERATED FROM DERF0069 C HERE TO STATEMENT 9 DERF0070 C DERF0071 21 DO 7 I=1,N DERF0072 II=I+N3 DERF0073 7 Y(II)=0.0 DERF0074 DO 8 I=1,NSYS DERF0075 DO 8 J=1,NSYS DERF0076 II=I+N3 DERF0077 8 Y(II)=AA(I,J)*XDIF(J)+Y(II) DERF0078 DO 9 I=1,NSYS DERF0079 II=I+N3 DERF0080 9 Y(II)=Y(II)+F(I) DERF0081 IF (ML.EQ.2) GO TO 11 DERF0082 C DERF0083 C THE HOMOGENEOUS DIFFERENTIAL EQUATIONS DERF0084 C DERF0085 DO 10 I=1,N1 DERF0086 DO 10 J=1,NSYS DERF0087 DO 10 K=1,NSYS DERF0088 II=N3+I*NSYS+J DERF0089 KK=I*NSYS+K DERF0090 10 Y(II)=AA(J,K)*Y(KK)+Y(II) DERF0091 11 CONTINUE DERF0092 RETURN DERF0093 END DERF0094 $IBFTC KAMSUX DECK SUBROUTINE KAMSUB (NSTART,NN,SPACE) KAMS0002 C DIMENSION DELY(4,NSYS*(NSYS-M+1)),BET(4),XV(5), KAMS0003 C 1FV(4,NSYS*(NSYS-M+1)),YU(5,NSYS*(NSYS-M+1)) KAMS0004 DIMENSION DELY(4,220),BET(4),XV(5),FV(4,220),YU(5,220) KAMS0005 COMMON /DER/ STIME KAMS0006 C COMMON Y(2*NSYS*(NSYS-M+1)+2) KAMS0007 COMMON Y(442) KAMS0008 DOUBLE PRECISION YU KAMS0009 C KAMS0010 C SUBROUTINES KAMSUB AND DERFUN ARE BASICALLY THE NUMERICAL KAMS0011 C INTEGRATION PROGRAM WHICH IS AVAILABLE FROM THE MECHANICAL KAMS0012 C ENGINEERING DEPARTMENT OF OKLAHOMA STATE UNIVERSITY KAMS0013 C KAMS0014 C NO INFORMATION IS REQUIRED IN THIS SUBROUTINE KAMS0015 C KAMS0016 IF (NSTART.EQ.1) GO TO 9977 KAMS0017 GO TO 1001 KAMS0018 C RUNGE-KUTTA KAMS0019 1000 LL=1 KAMS0020 1001 DO 1034 K=1,4 KAMS0021 DO 1350 I=1,NN KAMS0022 DELY(K,I)=Y(N2)*FV(MM,I) KAMS0023 Q=YU(MM,I) KAMS0024 1350 Y(I)=Q+BET(K)*DELY(K,I) KAMS0025 Y(NP1)=BET(K)*Y(N2)+XV(MM) KAMS0026 STIME=BET(K) KAMS0027 CALL DERFUN KAMS0028 DO 1100 I=1,NN KAMS0029 IPN2=I+N2 KAMS0030 1100 FV(MM,I)=Y(IPN2) KAMS0031 1034 CONTINUE KAMS0032 DO 1039 I=1,NN KAMS0033 DEL=(DELY(1,I)+2.0*DELY(2,I)+2.0*DELY(3,I)+DELY(4,I))/6.0 KAMS0034 YU(MM+1,I)=YU(MM,I)+DEL KAMS0035 1039 CONTINUE KAMS0036 MM=MM+1 KAMS0037 XV(MM)=XV(MM-1)+Y(N2) KAMS0038 DO 1400 I=1,NN KAMS0039 1400 Y(I)=YU(MM,I) KAMS0040 Y(NP1)=XV(MM) KAMS0041 STIME=1.0 KAMS0042 CALL DERFUN KAMS0043 C EXIT ROUTINE KAMS0044 DO 12 K=1,3 KAMS0045 XV(K)=XV(K+1) KAMS0046 DO 12 I=1,NN KAMS0047 FV(K,I)=FV(K+1,I) KAMS0048 12 YU(K,I)=YU(K+1,I) KAMS0049 LL=2 KAMS0050 MM=4 KAMS0051 XV(4)=XV(5) KAMS0052 DO 52 I=1,NN KAMS0053 IPN2=I+N2 KAMS0054 FV(4,I)=Y(IPN2) KAMS0055 52 YU(4,I)=YU(5,I) KAMS0056 GO TO 70 KAMS0057 9977 CONTINUE KAMS0058 ALPHA=Y(NN+1) KAMS0059 EPM=0.0 KAMS0060 7 MM=4 KAMS0061 8 BET(1)=0.5 KAMS0062 BET(2)=0.5 KAMS0063 BET(3)=1.0 KAMS0064 BET(4)=0.0 KAMS0065 5 N2=NN+2 KAMS0066 Y(N2)=SPACE KAMS0067 NP1=NN+1 KAMS0068 R=19.0/270.0 KAMS0069 XV(MM)=Y(NP1) KAMS0070 STIME=0.0 KAMS0071 3 CALL DERFUN KAMS0072 DO 320 I=1,NN KAMS0073 IPN2=I+N2 KAMS0074 FV(MM,I)=Y(IPN2) KAMS0075 320 YU(MM,I)=Y(I) KAMS0076 GO TO 1000 KAMS0077 70 RETURN KAMS0078 END KAMS0079 $IBFTC MINVX DECK C MINV0002 C ..................................................................MINV0003 C MINV0004 C SUBROUTINE MINV MINV0005 C MINV0006 C THIS IS AN IBM PROGRAM FROM THE SCIENTIFIC SUBROUTINE PACKAGE MINV0007 C MINV0008 C PURPOSE MINV0009 C INVERT A MATRIX MINV0010 C MINV0011 C USAGE MINV0012 C CALL MINV(A,N,D,L,M) MINV0013 C MINV0014 C DESCRIPTION OF PARAMETERS MINV0015 C A - INPUT MATRIX, DESTROYED IN COMPUTATION AND REPLACED BY MINV0016 C RESULTANT INVERSE. MINV0017 C N - ORDER OF MATRIX A MINV0018 C D - RESULTANT DETERMINANT MINV0019 C L - WORK VECTOR OF LENGTH N MINV0020 C M - WORK VECTOR OF LENGTH N MINV0021 C MINV0022 C REMARKS MINV0023 C MATRIX A MUST BE A GENERAL MATRIX MINV0024 C MINV0025 C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED MINV0026 C NONE MINV0027 C MINV0028 C METHOD MINV0029 C THE STANDARD GAUSS-JORDAN METHOD IS USED. THE DETERMINANT MINV0030 C IS ALSO CALCULATED. A DETERMINANT OF ZERO INDICATES THAT MINV0031 C THE MATRIX IS SINGULAR. MINV0032 C MINV0033 C ..................................................................MINV0034 C MINV0035 SUBROUTINE MINV (N,D) MINV0036 C DIMENSION L(NC),M(NC) MINV0037 DIMENSION L(20),M(20) MINV0038 C COMMON /OPCON/ X(NSYS),U(NC),XDEL(NSYS),UDEL(NC),C(NSYS),CU(NSYS) MINV0039 C 1MM(NSYS-M),FBC(NSYS-M),GX(NSYS,NSYS),XDIF(NSYS),UDIF(NC) MINV0040 C 2AA(NSYS,NSYS),B(NSYS,NSYS),F(NSYS),G(NC) MINV0041 COMMON /OPCON/ X(20),U(20),XDEL(20),UDEL(20),C(20),CU(20), MINV0042 1MM(20),FBC(20),GX(20,20),XDIF(20),UDIF(20), MINV0043 2AA(20,20),B(20,20),F(20),G(20) MINV0044 EQUIVALENCE (A(1),B(1,1)) MINV0045 C DIMENSION A(NSYS*NSYS) MINV0046 DIMENSION A(400) MINV0047 C MINV0048 C ...............................................................MINV0049 C MINV0050 C IF A DOUBLE PRECISION VERSION OF THIS ROUTINE IS DESIRED, THE MINV0051 C C IN COLUMN 1 SHOULD BE REMOVED FROM THE DOUBLE PRECISION MINV0052 C STATEMENT WHICH FOLLOWS. MINV0053 C MINV0054 C DOUBLE PRECISION A,D,BIGA,HOLD MINV0055 C MINV0056 C THE C MUST ALSO BE REMOVED FROM DOUBLE PRECISION STATEMENTS MINV0057 C APPEARING IN OTHER ROUTINES USED IN CONJUNCTION WITH THIS MINV0058 C ROUTINE. MINV0059 C MINV0060 C THE DOUBLE PRECISION VERSION OF THIS SUBROUTINE MUST ALSO MINV0061 C CONTAIN DOUBLE PRECISION FORTRAN FUNCTIONS. ABS IN STATEMENT MINV0062 C 10 MUST BE CHANGED TO DABS. MINV0063 C MINV0064 C ...............................................................MINV0065 C MINV0066 C SEARCH FOR LARGEST ELEMENT MINV0067 C MINV0068 D=1.0 MINV0069 NK=-N MINV0070 DO 80 K=1,N MINV0071 NK=NK+N MINV0072 L(K)=K MINV0073 M(K)=K MINV0074 KK=NK+K MINV0075 BIGA=A(KK) MINV0076 DO 20 J=K,N MINV0077 IZ=N*(J-1) MINV0078 DO 20 I=K,N MINV0079 IJ=IZ+I MINV0080 10 IF( ABS(BIGA)- ABS(A(IJ))) 15,20,20 MINV0081 15 BIGA=A(IJ) MINV0082 L(K)=I MINV0083 M(K)=J MINV0084 20 CONTINUE MINV0085 C MINV0086 C INTERCHANGE ROWS MINV0087 C MINV0088 J=L(K) MINV0089 IF(J-K) 35,35,25 MINV0090 25 KI=K-N MINV0091 DO 30 I=1,N MINV0092 KI=KI+N MINV0093 HOLD=-A(KI) MINV0094 JI=KI-K+J MINV0095 A(KI)=A(JI) MINV0096 30 A(JI) =HOLD MINV0097 C MINV0098 C INTERCHANGE COLUMNS MINV0099 C MINV0100 35 I=M(K) MINV0101 IF(I-K) 45,45,38 MINV0102 38 JP=N*(I-1) MINV0103 DO 40 J=1,N MINV0104 JK=NK+J MINV0105 JI=JP+J MINV0106 HOLD=-A(JK) MINV0107 A(JK)=A(JI) MINV0108 40 A(JI) =HOLD MINV0109 C MINV0110 C DIVIDE COLUMN BY MINUS PIVOT (VALUE OF PIVOT ELEMENT IS MINV0111 C CONTAINED IN BIGA) MINV0112 C MINV0113 45 IF(BIGA) 48,46,48 MINV0114 46 D=0.0 MINV0115 RETURN MINV0116 48 DO 55 I=1,N MINV0117 IF(I-K) 50,55,50 MINV0118 50 IK=NK+I MINV0119 A(IK)=A(IK)/(-BIGA) MINV0120 55 CONTINUE MINV0121 C MINV0122 C REDUCE MATRIX MINV0123 C MINV0124 DO 65 I=1,N MINV0125 IK=NK+I MINV0126 IJ=I-N MINV0127 DO 65 J=1,N MINV0128 IJ=IJ+N MINV0129 IF(I-K) 60,65,60 MINV0130 60 IF(J-K) 62,65,62 MINV0131 62 KJ=IJ-I+K MINV0132 A(IJ)=A(IK)*A(KJ)+A(IJ) MINV0133 65 CONTINUE MINV0134 C MINV0135 C DIVIDE ROW BY PIVOT MINV0136 C MINV0137 KJ=K-N MINV0138 DO 75 J=1,N MINV0139 KJ=KJ+N MINV0140 IF(J-K) 70,75,70 MINV0141 70 A(KJ)=A(KJ)/BIGA MINV0142 75 CONTINUE MINV0143 C MINV0144 C PRODUCT OF PIVOTS MINV0145 C MINV0146 D=D*BIGA MINV0147 C MINV0148 C REPLACE PIVOT BY RECIPROCAL MINV0149 C MINV0150 A(KK)=1.0/BIGA MINV0151 80 CONTINUE MINV0152 C MINV0153 C FINAL ROW AND COLUMN INTERCHANGE MINV0154 C MINV0155 K=N MINV0156 100 K=(K-1) MINV0157 IF(K) 150,150,105 MINV0158 105 I=L(K) MINV0159 IF(I-K) 120,120,108 MINV0160 108 JQ=N*(K-1) MINV0161 JR=N*(I-1) MINV0162 DO 110 J=1,N MINV0163 JK=JQ+J MINV0164 HOLD=A(JK) MINV0165 JI=JR+J MINV0166 A(JK)=-A(JI) MINV0167 110 A(JI) =HOLD MINV0168 120 J=M(K) MINV0169 IF(J-K) 100,100,125 MINV0170 125 KI=K-N MINV0171 DO 130 I=1,N MINV0172 KI=KI+N MINV0173 HOLD=A(KI) MINV0174 JI=KI-K+J MINV0175 A(KI)=-A(JI) MINV0176 130 A(JI) =HOLD MINV0177 GO TO 100 MINV0178 150 RETURN MINV0179 END MINV0180 $IBFTC ARRAYX DECK C ARRA0002 C ..................................................................ARRA0003 C ARRA0004 C SUBROUTINE ARRAY ARRA0005 C ARRA0006 C THIS IS AN IBM PROGRAM FROM THE SCIENTIFIC SUBROUTINE PACKAGE ARRA0007 C ARRA0008 C PURPOSE ARRA0009 C CONVERT DATA ARRAY FROM SINGLE TO DOUBLE DIMENSION OR VICE ARRA0010 C VERSA. THIS SUBROUTINE IS USED TO LINK THE USER PROGRAM ARRA0011 C WHICH HAS DOUBLE DIMENSION ARRAYS AND THE SSP SUBROUTINES ARRA0012 C WHICH OPERATE ON ARRAYS OF DATA IN A VECTOR FASHION. ARRA0013 C ARRA0014 C USAGE ARRA0015 C CALL ARRAY (MODE,I,J,N,M,S,D) ARRA0016 C ARRA0017 C DESCRIPTION OF PARAMETERS ARRA0018 C MODE - CODE INDICATING TYPE OF CONVERSION ARRA0019 C 1 - FROM SINGLE TO DOUBLE DIMENSION ARRA0020 C 2 - FROM DOUBLE TO SINGLE DIMENSION ARRA0021 C I - NUMBER OF ROWS IN ACTUAL DATA MATRIX ARRA0022 C J - NUMBER OF COLUMNS IN ACTUAL DATA MATRIX ARRA0023 C N - NUMBER OF ROWS SPECIFIED FOR THE MATRIX D IN ARRA0024 C DIMENSION STATEMENT ARRA0025 C M - NUMBER OF COLUMNS SPECIFIED FOR THE MATRIX D IN ARRA0026 C DIMENSION STATEMENT ARRA0027 C S - IF MODE=1, THIS VECTOR CONTAINS, AS INPUT, A DATA ARRA0028 C MATRIX OF SIZE I BY J IN CONSECUTIVE LOCATIONS ARRA0029 C COLUMN-WISE. IF MODE=2, IT CONTAINS A DATA MATRIX ARRA0030 C OF THE SAME SIZE AS OUTPUT. THE LENGTH OF VECTOR S ARRA0031 C IS IJ, WHERE IJ=I*J. ARRA0032 C D - IF MODE=1, THIS MATRIX (N BY M) CONTAINS, AS OUTPUT, ARRA0033 C A DATA MATRIX OF SIZE I BY J IN FIRST I ROWS AND ARRA0034 C J COLUMNS. IF MODE=2, IT CONTAINS A DATA MATRIX OF ARRA0035 C THE SAME SIZE AS INPUT. ARRA0036 C ARRA0037 C REMARKS ARRA0038 C VECTOR S CAN BE IN THE SAME LOCATION AS MATRIX D. VECTOR S ARRA0039 C IS REFERRED AS A MATRIX IN OTHER SSP ROUTINES, SINCE IT ARRA0040 C CONTAINS A DATA MATRIX. ARRA0041 C THIS SUBROUTINE CONVERTS ONLY GENERAL DATA MATRICES (STORAGEARRA0042 C MODE OF 0). ARRA0043 C ARRA0044 C SUBROUTINES AND FUNCTION SUBROUTINES REQUIRED ARRA0045 C NONE ARRA0046 C ARRA0047 C METHOD ARRA0048 C REFER TO THE DISCUSSION ON VARIABLE DATA SIZE IN THE SECTIONARRA0049 C DESCRIBING OVERALL RULES FOR USAGE IN THIS MANUAL. ARRA0050 C ARRA0051 C ..................................................................ARRA0052 C ARRA0053 SUBROUTINE ARRAY (MODE,I,J,N,M) ARRA0054 C COMMON /OPCON/ X(NSYS),U(NC),XDEL(NSYS),UDEL(NC),C(NSYS),CU(NSYS) ARRA0055 C 1MM(NSYS-M),FBC(NSYS-M),GX(NSYS,NSYS),XDIF(NSYS),UDIF(NC) ARRA0056 C 2AA(NSYS,NSYS),B(NSYS,NSYS),F(NSYS),G(NC) ARRA0057 COMMON /OPCON/ X(20),U(20),XDEL(20),UDEL(20),C(20),CU(20), ARRA0058 1MM(20),FBC(20),GX(20,20),XDIF(20),UDIF(20), ARRA0059 2AA(20,20),B(20,20),F(20),G(20) ARRA0060 EQUIVALENCE (S(1),DOU(1),B(1,1)) ARRA0061 C DIMENSION S(NSYS*NSYS),DOU(NSYS*NSYS) ARRA0062 DIMENSION S(400),DOU(400) ARRA0063 C ARRA0064 C ARRA0065 C IF IT IS NECESSARY THAT THIS SUBPROGRAM BE CARRIED OUT IN ARRA0066 C DOUBLE PRECISION, REMOVE THE C FROM THE FOLLOWING CARD ARRA0067 C DOUBLE PRECISION S,D ARRA0068 C ARRA0069 NI=N-I ARRA0070 C ARRA0071 C TEST TYPE OF CONVERSION ARRA0072 C ARRA0073 IF(MODE-1) 100, 100, 120 ARRA0074 C ARRA0075 C CONVERT FROM SINGLE TO DOUBLE DIMENSION ARRA0076 C ARRA0077 100 IJ=I*J+1 ARRA0078 NM=N*J+1 ARRA0079 DO 110 K=1,J ARRA0080 NM=NM-NI ARRA0081 DO 110 L=1,I ARRA0082 IJ=IJ-1 ARRA0083 NM=NM-1 ARRA0084 110 DOU(NM)=S(IJ) ARRA0085 GO TO 140 ARRA0086 C ARRA0087 C CONVERT FROM DOUBLE TO SINGLE DIMENSION ARRA0088 C ARRA0089 120 IJ=0 ARRA0090 NM=0 ARRA0091 DO 130 K=1,J ARRA0092 DO 125 L=1,I ARRA0093 IJ=IJ+1 ARRA0094 NM=NM+1 ARRA0095 125 S(IJ)=DOU(NM) ARRA0096 130 NM=NM+NI ARRA0097 C ARRA0098 140 RETURN ARRA0099 END ARRA0100 $IBFTC STOREX NODECK STOR0001 SUBROUTINE STORE (NSTOR,TRYSTP) STOR0002 C COMMON /STOR/ XS(NSYS,NSTOR),US(NC,NSTOR) STOR0003 COMMON /STOR/ XS(20,301),US(20,301) STOR0004 C STOR0005 C THE STORED STARTING SOLUTION IS DEFINED IN THIS SUBROUTINE STOR0006 C STOR0007 C C* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C C THIS SUBROUTINE IS SUPPLIED BY THE WRITER. THE FOLLOWING IS C AN EXAMPLE ONLY. C C* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C DO 1 I=1,NSTOR T=I-1 T=T*TRYSTP XS(1,I)=0.0 XS(2,I)=0.0 XS(3,I)=1.0-T/5.0 XS(4,I)=0.0 XS(5,I)=0.0 US(1,I)=0.0 1 US(2,I)=0.0 RETURN STOR0008 END STOR0009 $IBFTC EQUAX NODECK EQF 0001 SUBROUTINE EQUA EQF 0002 C COMMON /OPCON/ X(NSYS),U(NC),XDEL(NSYS),UDEL(NC),C(NSYS),CU(NSYS) EQF 0003 C 1MM(NSYS-M),FBC(NSYS-M),GX(NSYS,NSYS),XDIF(NSYS),UDIF(NC) EQF 0004 C 2AA(NSYS,NSYS),B(NSYS,NSYS),F(NSYS),G(NC) EQF 0005 COMMON /OPCON/ X(20),U(20),XDEL(20),UDEL(20),C(20),CU(20), EQF 0006 1MM(20),FBC(20),GX(20,20),XDIF(20),UDIF(20), EQF 0007 2AA(20,20),B(20,20),F(20),G(20) EQF 0008 COMMON /OPCONA/ ML,N3,NSYS,NC,N1,N EQF 0009 C EQF 0010 C DEFINE F(I) IN THIS SUBPROGRAM EQF 0011 C EQF 0012 C C* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C C THIS SUBROUTINE IS SUPPLIED BY THE WRITER. THE FOLLOWING IS C AN EXAMPLE ONLY. C C* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C F(1)=X(2) F(2)=X(5) F(3)=X(4) F(4)=U(1) F(5)=U(2)-X(3) RETURN EQF 0013 END EQF 0014 $IBFTC JABFXX NODECK FX 0001 SUBROUTINE JABFX FX 0002 C COMMON /OPCON/ X(NSYS),U(NC),XDEL(NSYS),UDEL(NC),C(NSYS),CU(NSYS) FX 0003 C 1MM(NSYS-M),FBC(NSYS-M),GX(NSYS,NSYS),XDIF(NSYS),UDIF(NC) FX 0004 C 2AA(NSYS,NSYS),B(NSYS,NSYS),F(NSYS),G(NC) FX 0005 COMMON /OPCON/ X(20),U(20),XDEL(20),UDEL(20),C(20),CU(20), FX 0006 1MM(20),FBC(20),GX(20,20),XDIF(20),UDIF(20), FX 0007 2AA(20,20),B(20,20),F(20),G(20) FX 0008 COMMON /OPCONA/ ML,N3,NSYS,NC,N1,N FX 0009 EQUIVALENCE (FX(1,1),GX(1,1)) FX 0010 C DIMENSION FX(NSYS,NSYS) FX 0011 DIMENSION FX(20,20) FX 0012 DO 1 I=1,NSYS FX 0013 DO 1 J=1,NSYS FX 0014 1 FX(I,J)=0.0 FX 0015 C FX 0016 C DEFINE NON ZERO ELEMENTS OF FX FX 0017 C FX 0018 C C* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C C THIS SUBROUTINE IS SUPPLIED BY THE WRITER. THE FOLLOWING IS C AN EXAMPLE ONLY. C C* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C FX(1,2)=1.0 FX(2,5)=1.0 FX(3,4)=1.0 FX(5,3)=-1.0 RETURN FX 0019 END FX 0020 $IBFTC JABFUX NODECK FU 0001 SUBROUTINE JABFU FU 0002 C COMMON /OPCON/ X(NSYS),U(NC),XDEL(NSYS),UDEL(NC),C(NSYS),CU(NSYS) FU 0003 C 1MM(NSYS-M),FBC(NSYS-M),GX(NSYS,NSYS),XDIF(NSYS),UDIF(NC) FU 0004 C 2AA(NSYS,NSYS),B(NSYS,NSYS),F(NSYS),G(NC) FU 0005 COMMON /OPCON/ X(20),U(20),XDEL(20),UDEL(20),C(20),CU(20), FU 0006 1MM(20),FBC(20),GX(20,20),XDIF(20),UDIF(20), FU 0007 2AA(20,20),B(20,20),F(20),G(20) FU 0008 COMMON /OPCONA/ ML,N3,NSYS,NC,N1,N FU 0009 EQUIVALENCE (FU(1,1),GX(1,1)) FU 0010 C DIMENSION FU(NSYS,NSYS) FU 0011 DIMENSION FU(20,20) FU 0012 DO 1 I=1,NSYS FU 0013 DO 1 J=1,NC FU 0014 1 FU(I,J)=0.0 FU 0015 C FU 0016 C DEFINE NON ZERO ELEMENTS OF FU FU 0017 C FU 0018 C C* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C C THIS SUBROUTINE IS SUPPLIED BY THE WRITER. THE FOLLOWING IS C AN EXAMPLE ONLY. C C* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C FU(4,1)=1.0 FU(5,2)=1.0 RETURN FU 0019 END FU 0020 $IBFTC EQGX NODECK EQG 0001 SUBROUTINE EQG EQG 0002 C COMMON /OPCON/ X(NSYS),U(NC),XDEL(NSYS),UDEL(NC),C(NSYS),CU(NSYS) EQG 0003 C 1MM(NSYS-M),FBC(NSYS-M),GX(NSYS,NSYS),XDIF(NSYS),UDIF(NC) EQG 0004 C 2AA(NSYS,NSYS),B(NSYS,NSYS),F(NSYS),G(NC) EQG 0005 COMMON /OPCON/ X(20),U(20),XDEL(20),UDEL(20),C(20),CU(20), EQG 0006 1MM(20),FBC(20),GX(20,20),XDIF(20),UDIF(20), EQG 0007 2AA(20,20),B(20,20),F(20),G(20) EQG 0008 COMMON /OPCONA/ ML,N3,NSYS,NC,N1,N EQG 0009 C EQG 0010 C DEFINE G(I) IN THIS PROGRAM EQG 0011 C EQG 0012 C C* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C C THIS SUBROUTINE IS SUPPLIED BY THE WRITER. THE FOLLOWING IS C AN EXAMPLE ONLY. C C* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C G(1)=U(1)+3.0*X(1)*X(4) G(2)=U(2)+3.0*X(1)*X(5)-2.0*X(2)*X(2) RETURN EQG 0013 END EQG 0014 $IBFTC JABGXX NODECK GX 0001 SUBROUTINE JABGX GX 0002 C COMMON /OPCON/ X(NSYS),U(NC),XDEL(NSYS),UDEL(NC),C(NSYS),CU(NSYS) GX 0003 C 1MM(NSYS-M),FBC(NSYS-M),GX(NSYS,NSYS),XDIF(NSYS),UDIF(NC) GX 0004 C 2AA(NSYS,NSYS),B(NSYS,NSYS),F(NSYS),G(NC) GX 0005 COMMON /OPCON/ X(20),U(20),XDEL(20),UDEL(20),C(20),CU(20), GX 0006 1MM(20),FBC(20),GX(20,20),XDIF(20),UDIF(20), GX 0007 2AA(20,20),B(20,20),F(20),G(20) GX 0008 COMMON /OPCONA/ ML,N3,NSYS,NC,N1,N GX 0009 DO 1 I=1,NC GX 0010 DO 1 J=1,NSYS GX 0011 1 GX(I,J)=0.0 GX 0012 C GX 0013 C DEFINE NON ZERO ELEMENTS OF GX GX 0014 C GX 0015 C C* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C C THIS SUBROUTINE IS SUPPLIED BY THE WRITER. THE FOLLOWING IS C AN EXAMPLE ONLY. C C* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C GX(1,1)=3.0*X(4) GX(1,4)=3.0*X(1) GX(2,1)=3.0*X(5) GX(2,2)=-4.0*X(2) GX(2,5)=3.0*X(1) RETURN GX 0016 END GX 0017 $IBFTC JABGUX NODECK GU 0001 SUBROUTINE JABGU GU 0002 C COMMON /OPCON/ X(NSYS),U(NC),XDEL(NSYS),UDEL(NC),C(NSYS),CU(NSYS) GU 0003 C 1MM(NSYS-M),FBC(NSYS-M),GX(NSYS,NSYS),XDIF(NSYS),UDIF(NC) GU 0004 C 2AA(NSYS,NSYS),B(NSYS,NSYS),F(NSYS),G(NC) GU 0005 COMMON /OPCON/ X(20),U(20),XDEL(20),UDEL(20),C(20),CU(20), GU 0006 1MM(20),FBC(20),GX(20,20),XDIF(20),UDIF(20), GU 0007 2AA(20,20),B(20,20),F(20),G(20) GU 0008 COMMON /OPCONA/ ML,N3,NSYS,NC,N1,N GU 0009 EQUIVALENCE (GU(1,1),B(1,1)) GU 0010 C DIMENSION GU(NSYS,NSYS) GU 0011 DIMENSION GU(20,20) GU 0012 DO 1 I=1,NC GU 0013 DO 1 J=1,NC GU 0014 1 GU(I,J)=0.0 GU 0015 C GU 0016 C DEFINE NON ZERO ELEMENTS OF GU GU 0017 C GU 0018 C C* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C C THIS SUBROUTINE IS SUPPLIED BY THE WRITER. THE FOLLOWING IS C AN EXAMPLE ONLY. C C* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C GU(1,1)=1.0 GU(2,2)=1.0 CALL ARRAY (2,NC,NC,20,20) GU 0019 CALL MINV (NC,D) GU 0020 IF (D.EQ.0.0) GO TO 2 GU 0021 CALL ARRAY (1,NC,NC,20,20) GU 0022 RETURN GU 0023 2 CONTINUE GU 0024 WRITE (6,3) GU 0025 3 FORMAT (30H DETERMINANT OF GU EQUALS ZERO) GU 0026 CALL EXIT GU 0027 RETURN GU 0028 END GU 0029 $ENTRY $DATA $BLOCK BCD,0084 5 2 3 101 10 .05 1.0 .05 2 0.0 3 0.0 ~ $IBSYS $STOP