Liren Large Software Subsidy 9

home *** CD-ROM | disk | FTP | other *** search

/ Liren Large Software Subsidy 9 / 09.iso / e / e003 / 2.ddi / MODEL04.FOR < prev next >

Wrap

Text File | 1987-09-17 | 69.4 KB | 868 lines

SUBROUTINE FCOPY(ID,IF) 00086440 RETURN 00086450 END 00086460 SUBROUTINE AUTBND(IES,NUMNP,NMP,NML,NUMEL,NUMEL2) 00019870 IMPLICIT REAL*8(A-H,O-Z) 00019880 REAL*8 NPAR 00019890 COMMON A(1) 00019900 COMMON /ELPAR/ NPAR(14),NUMN ,MBAND,NELTYP,N1,N2,N3,N4,N5,MTOT,NEQ00019910 & ,RRELPA(24) R0019911 DIMENSION C(3),ST(3) 00019920 COMMON/TRASH/ ND(100), COSN(100,3),RRTRAS(140) R0019930 COMMON/JUNK/NSN,I,D,J,K,L,II,NSN1,NC,NDOF,N6,DF,N,LX,JL,J1,L1,IL, 00019940 & RRJUNK(217) R0019941 DATA C/2HNM,2HND,2HNR/ 00019950 REWIND 1 00019960 NSN1=0 00019970 II=1 00019980 NZ=NUMNP 00019990 NMP=NUMNP+1 00020000 CALL CNSTR2 (0,NMP,A(1),NZ,NC,NUMEL2,JL,ND, COSN,NS,ST) 00020010 NML=NUMEL 00020020 100 READ(5,110)NSN,D,ST 00020030 IF(NSN.EQ.0) RETURN 00020040 110 FORMAT( I5,A2,3X,3F10.0) 00020050 00020060 NC=0 00020070 NS=0 00020080 DO 120 I=1,3 00020090 IF(ST(I).NE.0.0) NS=1 00020100 IF(D.EQ.C(I)) NC=I 00020110 120 CONTINUE 00020120 IF(NC.EQ.0) WRITE(6,130)NSN 00020130 IF(NC.EQ.1) WRITE(6,140)NSN 00020140 IF(NC.EQ.2) WRITE(6,150)NSN 00020150 IF(NC.EQ.3) WRITE(6,160)NSN 00020160 130 FORMAT (1H0,20X,33H NO CONSTRAINTS SPEC. FOR SURFACE,I5) 00020170 140 FORMAT (1H0,20X,31H CONSTRAINTS SPEC. FOR SURFACE,I5,7H ------, 00020180 $15HNO MOTION------) 00020190 150 FORMAT (1H0,20X,31H CONSTRAINTS SPEC. FOR SURFACE,I5,7H ------, 00020200 $18HNO DISPLACEMENT---) 00020210 160 FORMAT (1H0,20X,31H CONSTRAINTS SPEC. FOR SURFACE,I5,7H ------, 00020220 $15HNO ROTATION----) 00020230 IF(NC.EQ.0) GO TO 100 00020240 IF(NSN.LE.NSN1) REWIND 1 00020250 IF(NSN.LE.NSN1) II=1 00020260 NSN1=NSN 00020270 DO 180 I=II,IES 00020280 IL=I 00020290 READ (1) J1,L1 00020300 LX=L1/100+1 00020310 IF(NSN.EQ.J1) GO TO 190 00020320 DO 170 J=1,LX 00020330 JL=100 00020340 IF(J.EQ.LX) JL=L1-(LX-1)*100 00020350 READ (1) (ND(K),( COSN(K,M),M=1,3),K=1,JL) 00020360 170 CONTINUE 00020370 180 CONTINUE 00020380 190 II=IL 00020390 IF(NSN.EQ.J1) GO TO 210 00020400 WRITE(6,200)NSN 00020410 200 FORMAT (1X ,20X,44H NO DIRECTION COSINES COULD BE FOUND FOR SUR, 00020420 $4HFACE,I5) 00020430 GO TO 100 00020440 210 DO 250 I=1,LX 00020450 JL=100 00020460 IF(I.EQ.LX) JL=L1-(LX-1)*100 00020470 READ (1) (ND(K),( COSN(K,M),M=1,3),K=1,JL) 00020480 DO 240 J=1,JL 00020490 NDOF=0 00020500 DO 220 K=1,3 00020510 DF= DABS( COSN(J,K) ) 00020520 IF(DF.GT.0.999)NDOF=K 00020530 220 CONTINUE 00020540 IF(NS.EQ.1) NDOF=0 00020550 IF(NDOF.EQ.0) NMP=NMP+1 00020560 N6=NMP*3+ 1 00020570 IF(N6.LT.MTOT) GO TO 240 00020580 WRITE(6,230)NSN 00020590 230 FORMAT (1X ,20X,43HTHERE ARE TOO MANY NODES REQUIRING BOUNDARY,/, 00020600 $20X,48HELEMENTS. MANUAL GENERATION OF BOUNDARY ELEMENTS/,20X 00020610 $,45HMAY BE REQUIRED. EXECUTION STOPPED ON SURFACE,I5) 00020620 CALL CLOSE 00020630 CALL EXIT 00020640 240 CONTINUE 00020650 CALL CNSTR2 (1,NMP,A(1),NZ,NC,NUMEL2,JL,ND, COSN,NS,ST) 00020660 250 CONTINUE 00020670 GO TO 100 00020680 END 00020690 SUBROUTINE CNSTR2(KK,NMZ,ID,N,NC,NUMEL2,JL,ND, COSN,NS,ST) 00045020 IMPLICIT REAL*8(A-H,O-Z) 00045030 REAL*8 ID 00045040 DIMENSION ID(NMZ,3) 00045050 DIMENSION X(3) ,ND(100), COSN(100,3) 00045060 COMMON/PREP/XMX,XAD,KSKIP,NDYN,I1,RRPREP(7) R0045070 COMMON/JUNK/ DUM(100), NM,I,Z(5),J,NRJUNK(241) R0045080 DIMENSION Y(3),ST(3) 00045090 REWIND 8 00045100 READ (8) ((ID(I,J),J=1,3),I=1,N) 00045110 IF(KK.GT.0) GO TO 110 00045120 NM=NMZ 00045130 XAD1I=1.0+XAD+I1 00045140 DO 100 I=1,3 00045150 100 ID(NM,I)=XAD1I 00045160 GO TO 170 00045170 110 NMP=N 00045180 DO 160 J=1,JL 00045190 NDOF=0 00045200 DO 120 K=1,3 00045210 Y(K)=ST(K) 00045220 DF= DABS( COSN(J,K) ) 00045230 IF(DF.GT.0.999)NDOF=K 00045240 120 X(K)= COSN(J,K) 00045250 N=ND(J) 00045260 IF(NS.EQ.1) NDOF=0 00045270 130 IF(NDOF.GT.0) GO TO 150 00045280 NMP=NMP+1 00045290 SC=01. 00045300 IF(NC.EQ.1) SC=11. 00045310 IF(NC.EQ.2) SC=10. 00045320 DO 140 I=1,3 00045330 140 ID(NMP,I)= X(I)/XMX+XAD+1.0+I1 00045340 NUMEL2=NUMEL2+1 00045350 Z(1)=N 00045360 Z(2)=NM 00045370 Z(3)=NMP 00045380 Z(4)=0 00045390 Z(5)=0 00045400 WRITE (9) Z,SC,Y 00045410 GO TO 160 00045420 150 NN=ID(N,NDOF) 00045430 I=I1 00045440 IF(NC.EQ.1) I=I+1 00045450 IF(NC.EQ.2) I=1 00045460 IF(NN.EQ.1.AND.I.EQ.I1) I=I1+1 00045470 IF( I.EQ.1.AND.NN.EQ.I1)I=I1+1 00045480 IF(NN.GT.I1) I=NN 00045490 ID(N,NDOF) =(ID(N,NDOF)-NN)+I 00045500 160 CONTINUE 00045510 170 CONTINUE 00045520 REWIND 8 00045530 NMP=NMZ 00045540 N=NMP 00045550 WRITE (8) ((ID(I,J),J=1,3),I=1,NMP) 00045560 RETURN 00045570 END 00045580 SUBROUTINE AUTPR(NUMEL,ID2,IES,ID4,NADEL,NADND) 00020700 IMPLICIT REAL*8(A-H,O-Z) 00020710 REAL*8 ID2 00020720 REAL*8 ID4 00020730 DIMENSION ID4(NADEL,NADND) 00020740 DIMENSION ID2(NUMEL,5) 00020750 COMMON/JUNK/I,J,K,N,J1,J2,J3,J4,NPT,NSN,NSN1,II,IL,LX,KM,NNN,NN1, R0020760 & NRJUNK(437) R0020761 COMMON/TRASH/ IA( 20),RRTRAS(480) R0020770 REWIND 2 00020780 II=1 00020790 NSN1=0 00020800 REWIND 4 00020810 READ (4) ((ID2(I,J),J=1,5),I=1,NUMEL) 00020820 IF(NADEL.GT.1) READ(4) ((ID4(I,J),J=1,NADND),I=1,NUMEL) 00020830 100 READ(5,110)NSN,NPT 00020840 IF(NSN.EQ.0) GO TO 220 00020850 110 FORMAT (2I5) 00020860 IF(NSN.LT.NSN1) REWIND 2 00020870 IF(NSN.LT.NSN1) II=1 00020880 NSN1=NSN 00020890 DO 130 I=II,IES 00020900 IL=I 00020910 READ (2) J1,J2,J3,J4 00020920 LX=(J4-16)/20+1 00020930 IF(NSN.EQ.J1) GO TO 140 00020940 JL=16 00020950 IF(J4.LE.16) JL=J4 00020960 READ (2) (IA(K),K=1,JL) 00020970 IF(J4.LE.16) GO TO 130 00020980 DO 120 J=1,LX 00020990 JL=20 00021000 IF(J.EQ.LX) JL=J4-(LX-1)*20 -16 00021010 IF(JL.EQ.0) GO TO 130 00021020 READ (2) (IA(K),K=1,JL) 00021030 120 CONTINUE 00021040 130 CONTINUE 00021050 140 II=IL 00021060 IF(NSN.EQ.J1) GO TO 160 00021070 WRITE(6,150)NSN 00021080 150 FORMAT (1H0,20X, 38H NO DATA FOUND TO ALLOW PRESSURE TO BE/20X, 00021090 $ 18HAPPLIED TO SURFACE,I5) 00021100 GO TO 100 00021110 160 CONTINUE 00021120 WRITE(6,170)NPT,NSN 00021130 170 FORMAT(1H0,20X, 13HPRESSURE TYPE,I5, 28H IS BEING APPLIED TO SURFA00021140 $CE, I5//) 00021150 JL=16 00021160 IF(J4.LE.16) JL=J4 00021170 READ (2) (IA(K),K=1,JL) 00021180 KM=10000 00021190 NPTKM=NPT*KM 00021200 I=0 00021210 GO TO 190 00021220 180 I=I+1 00021230 IF(J4.LE.16) GO TO 210 00021240 JL=20 00021250 IF(I.EQ.LX) JL=J4-(LX-1)*20 -16 00021260 IF(JL.EQ.0) GO TO 210 00021270 READ (2) (IA(K),K=1,JL) 00021280 190 DO 200 J=1,JL 00021290 N=IA(J) 00021300 ZNN=ID2(N,5) 00021310 NN1=ZNN/KM 00021320 NN1= MOD(NN1,100)*KM 00021330 ZNN=ZNN-NN1+NPTKM 00021340 ID2( N,5)=ZNN 00021350 200 CONTINUE 00021360 210 IF(I.LT.LX) GO TO 180 00021370 GO TO 100 00021380 220 REWIND 4 00021390 WRITE (4) ((ID2(I,J),J=1,5),I=1,NUMEL) 00021400 IF(NADEL.GT.1)WRITE(4) ((ID4(I,J),J=1,NADND),I=1,NUMEL) 00021410 RETURN 00021420 END 00021430 SUBROUTINE NODINP (NC,NUMNP,NP,ID,NZZ) 00155700 IMPLICIT REAL*8(A-H,O-Z) 00155710 REAL*8 ID 00155720 DIMENSION ID(NZZ,3) 00155730 COMMON/PREP/XMX,XAD,KSKIP,NDYN,I1,I99,POS,PRTCOD 00155740 $ ,POSSAV,PRTOFF,PRTON,PRTDUM,IDIRC 00155750 DIMENSION C(3) 00155760 DIMENSION C1(4) 00155770 COMMON/QTSARG/ X(3,50),Y(3,50),Z(3,50),TI(3,3,50),XC(3),XI(3) 00155780 $,XX(3),DX(3) 00155790 $,CORD(20,3),PERR,PERS,PERT,H(20),CZ(3),RRQTSA(2) R0155800 DIMENSION NOD(8),N3D(20) 00155810 DATA C/ 4HRECT,4HSPHR,4HCYLD/ 00155820 DATA C1/1H ,1HR,1HS,1HC/ 00155830 CALL FILES(26) 00155840 XM=XMX/2. 00155850 IF(PRTCOD.EQ.PRTOFF) GO TO 195 00155860 IF(POS.EQ.PRTDUM.AND.PRTCOD.NE.PRTON) GO TO 195 00155870 WRITE(6,100) 00155880 100 FORMAT (1X ,20X,32HNODAL POINT COORDINATES AS INPUT) 00155890 WRITE(6,110) 00155900 WRITE(6,130) 00155910 WRITE(6,140) 00155920 WRITE(6,170) 00155930 WRITE(6,150) 00155940 WRITE(6,120) 00155950 WRITE(6,130) 00155960 WRITE(6,140) 00155970 WRITE(6,170) 00155980 WRITE(6,160) 00155990 WRITE(6,180) 00156000 110 FORMAT (1H0,20X,27HFOR CYLINDRICAL COORDINATES/) 00156010 120 FORMAT (1H0,20X,25HFOR SPHERICAL COORDINATES/) 00156020 130 FORMAT (1H0,20X,5HX = R) 00156030 140 FORMAT (1H0,20X,5HY = O) 00156040 150 FORMAT (1H0,20X,5HZ = Z) 00156050 160 FORMAT (1H0,20X,5HZ = O) 00156060 170 FORMAT (1H+,20X,5H -) 00156070 180 FORMAT (1H+,20X,5H / //) 00156080 WRITE(6,190) 00156090 190 FORMAT (1H0,10X,4HNODE,11X,23HNODAL POINT COORDINATES,20X, 00156100 $6HCOORD.,10X,6HCOORD./11X,3HNO.,10X,1HX,15X,1HY,15X,1HZ,12X, 00156110 $6HSYSTEM,10X,5H TYPE ,7H INC.,5X,10HREF. FACT.///) 00156120 195 CONTINUE 00156130 IF (NP.GT.1) REWIND 8 00156140 IF (NP.GT.1) READ (8) ((ID(I,J),J=1,3),I=1,NP) 00156150 IF(NP.GT.1) NP=NP+1 00156160 IF(NP.GE.NUMNP) GO TO 210 00156170 XAD1I=XAD+1.0+I1 00156180 DO 200 I=NP,NUMNP 00156190 DO 200 J=1,3 00156200 200 ID(I,J)=XAD1I 00156210 210 KO=1 00156220 220 READ (5,230) N,XX,KS,C2,KN,PER 00156230 IF(N.EQ.0) GO TO 380 00156240 IF(N.EQ.-2) GO TO 410 00156250 IF(N.EQ.-3) GO TO 600 00156260 KT=1 00156270 IF(C2.EQ.C1(3)) KT=2 00156280 IF(C2.EQ.C1(4)) KT=3 00156290 IF(KT.GT.3) GO TO 390 00156300 IF(PRTCOD.EQ.PRTOFF) GO TO 225 00156310 IF(POS.EQ.PRTDUM.AND.PRTCOD.NE.PRTON) GO TO 225 00156320 WRITE(6,240)N,XX,KS,C(KT),KN,PER 00156330 225 CONTINUE 00156340 IF(N.GT.NUMNP) GO TO 390 00156350 IF(KS.GT.NC) GO TO 390 00156360 230 FORMAT(I10,3F10.0,I5,4X,A1,I5,F10.0) 00156370 240 FORMAT (9X,I5,3(5X,F10.4),I16,11X,A4,I6,F15.5) 00156380 IF(KO.EQ.1) GO TO 340 00156390 IF(KN.EQ.0) GO TO 340 00156400 IF((N-NI).LT.KN)GO TO 390 00156410 KDT=N-NI 00156420 KDT=MOD(KDT,KN) 00156430 IF(KDT.NE.0) GO TO 390 00156440 250 NUMINT=(N-NI)/KN 00156450 SUM=NUMINT 00156460 IF(PER.EQ.0.0) GO TO 270 00156470 PER=PER/100.0 00156480 LLL=NUMINT-1 00156490 SUM=1.0 00156500 DO 260 I=1,LLL 00156510 260 SUM=SUM+PER**I 00156520 270 CONTINUE 00156530 IF( PER.EQ.0.) PER=1.00 00156540 DO 280 I=1,3 00156550 280 DX(I)=(XX(I)-XI(I))/SUM 00156560 FACT=1.0/PER 00156570 LLL=NUMINT 00156580 DO 330 J=1,LLL 00156590 FACT=FACT*PER 00156600 NN=NI+J*KN 00156610 DO 290 JJ=1,3 00156620 290 XI(JJ)=XI(JJ)+DX(JJ) *FACT 00156630 CALL CONVER (KS,KT) 00156640 DO 320 JJ=1,3 00156650 IF(DABS(XC(JJ)).LT.XM) GO TO 310 00156660 WRITE(6,300)NN 00156670 KSKIP=1 00156680 300 FORMAT (1X ,20HA COORDINATE OF NODE,I5,23H IS LARGER THAN THE MAX,00156690 $22H. SPECIFIED COORDINATE) 00156700 310 CONTINUE 00156710 320 ID(NN,JJ)=XC(JJ)/XMX+XAD 00156720 330 CONTINUE 00156730 340 KO=0 00156740 NI=N 00156750 DO 350 J=1,3 00156760 350 XI(J)=XX(J) 00156770 IF(KN.GT.0) GO TO 220 00156780 CALL CONVER (KS,KT) 00156790 DO 370 I=1,3 00156800 IF(XC(I ).LT.XM) GO TO 360 00156810 WRITE(6,300)N 00156820 CALL CLOSE 00156830 CALL EXIT 00156840 360 CONTINUE 00156850 370 ID(N,I)=XC(I)/XMX+XAD 00156860 GO TO 220 00156870 380 REWIND 8 00156880 WRITE (8) ((ID(I,J),J=1,3),I= 1,NUMNP) 00156890 RETURN 00156900 390 WRITE(6,400)N 00156910 400 FORMAT (//20X,13HERROR ON NODE,I10//) 00156920 KSKIP=1 00156930 GO TO 220 00156940 410 READ (5,420) NOD,INCS,INCT,PERS,PERT 00156950 420 FORMAT(10I5,2F10.0) 00156960 IF(PERS.LE.0.0) PERS=100. 00156970 IF(PERT.LE.0.0) PERT=100. 00156980 IF(INCS.EQ.0) INCS=1 00156990 IF(INCT.EQ.0) INCT=NOD(2)-NOD(1)+1 00157000 WRITE(6,430)NOD,INCS,INCT,PERS,PERT 00157010 430 FORMAT(//20X,29HSURFACE COORDINATE GENERATION 00157020 $ /20X,27HNODE NOS. FOR CORNERS 1-8 =,1X,8I5 00157030 $ /20X,35HNODE INCREMENT IN THE S DIRECTION =,1X,I5 00157040 $ /20X,35HNODE INCREMENT IN THE T DIRECTION =,1X,I5 00157050 $ /20X,38HREFINEMENT FACTOR IN THE S DIRECTION =,1X,F15.5 00157060 $ /20X,38HREFINEMENT FACTOR IN THE T DIRECTION =,1X,F15.5//)00157070 DO 480 I=1,8 00157080 J=NOD(I) 00157090 IF(J.GE.0.AND.J.LE.NUMNP) GO TO 450 00157100 WRITE(6,440)NOD(I) 00157110 440 FORMAT(/20X,5HNODE ,I5,16H IS OUT OF RANGE//) 00157120 KSKIP=1 00157130 GO TO 220 00157140 450 DO 460 K=1,3 00157150 460 CORD(I,K)=0.0 00157160 IF(J.EQ.0) GO TO 480 00157170 DO 470 K=1,3 00157180 NNN=ID(J,K) 00157190 IF(NNN.LT.0) NNN=NNN-1 00157200 470 CORD(I,K)=(ID(J,K)-NNN-XAD)*XMX 00157210 480 CONTINUE 00157220 NI=4 00157230 DO 490 I=5,8 00157240 IF(NOD(I).GT.0) NI=8 00157250 H(I)=0.0 00157260 490 CONTINUE 00157270 DO 500 I=1,4 00157280 IF(NOD(I).EQ.0) WRITE(6,510)I 00157290 IF(NOD(I).EQ.0) GO TO 220 00157300 500 CONTINUE 00157310 510 FORMAT (/20X,7HCORNER ,I1,19H SHOULD NOT BE ZERO//) 00157320 NODE=NOD(1) 00157330 NUMDS=(NOD(2)-NOD(1))/INCS+1 00157340 NUMDT=(NOD(3)-NOD(2))/INCT+1 00157350 NX=NOD(1)-INCS+(NUMDS*NUMDT*INCS)+(INCT-NUMDS*INCS)*(NUMDT-1) 00157360 IF(NX.EQ.NOD(3)) GO TO 515 00157370 WRITE(6,512) 00157380 512 FORMAT(//20X,45HSURFACE GENERATION WILL BE TERMINATED BECAUSE, 00157390 $ /20X,44HEITHER SOME OF THE SUPPLIED CORNER NODE NOS. 00157400 $ /20X,38HARE WRONG OR THE INCREMENTS ARE WRONG.//) 00157410 KSKIP=1 00157420 GO TO 220 00157430 515 CONTINUE 00157440 T=-1. 00157450 PERS=PERS/100.0 00157460 PERT=PERT/100.0 00157470 LLL=NUMDS-2 00157480 SUMS=1.0 00157490 DO 520 I=1,LLL 00157500 520 SUMS=SUMS+PERS**I 00157510 LLL=NUMDT-2 00157520 SUMT=1.0 00157530 DO 530 I=1,LLL 00157540 530 SUMT=SUMT+PERT**I 00157550 FACTT=1.0/PERT 00157560 IF(PERS.EQ.1.0)SUMS=NUMDS-1 00157570 IF(PERT.EQ.1.0)SUMT=NUMDT-1 00157580 DS=2.0/SUMS 00157590 DT=2.0/SUMT 00157600 DO 590 I=1,NUMDT 00157610 S=-1. 00157620 FACTS=1.0/PERS 00157630 DO 580 J=1,NUMDS 00157640 IF(NI.NE.8) GO TO 540 00157650 IF(NOD(5).GT.0) 00157660 $H(5)=(1.-S**2)*(1.-T)*0.5 00157670 IF(NOD(6).GT.0) 00157680 $H(6)=(1.-T**2)*(1.+S)*0.5 00157690 IF(NOD(7).GT.0) 00157700 $H(7)=(1.-S**2)*(1.+T)*0.5 00157710 IF(NOD(8).GT.0) 00157720 $H(8)=(1.-T**2)*(1.-S)*0.5 00157730 540 H(1)=(1.-S)*(1.-T)* 0.25-(H(5)+H(8)) *0.5 00157740 H(2)=(1.+S)*(1.-T)* 0.25-(H(5)+H(6)) *0.5 00157750 H(3)=(1.+S)*(1.+T)* 0.25-(H(6)+H(7)) *0.5 00157760 H(4)=(1.-S)*(1.+T)* 0.25-(H(7)+H(8)) *0.5 00157770 DO 550 JJ=1,3 00157780 550 CZ(JJ)=0.0 00157790 DO 560 II=1,NI 00157800 DO 560 JJ=1,3 00157810 560 CZ(JJ)=CZ(JJ)+H(II)*CORD(II,JJ) 00157820 DO 570 JJ=1,3 00157830 570 ID(NODE,JJ)=CZ(JJ)/XMX+XAD 00157840 NODE=NODE+INCS 00157850 FACTS=FACTS*PERS 00157860 580 S=S+DS*FACTS 00157870 NODE=NODE-(NUMDS)*INCS+INCT 00157880 FACTT=FACTT*PERT 00157890 590 T=T+DT*FACTT 00157900 IF(KS.NE.0) CALL SRFC(NOD,INCS,INCT,NUMDS,NUMDT, 00157910 $XAD,XMX,NZZ,ID,KS,CORD) 00157920 GO TO 220 00157930 600 READ (5,610) (N3D(I),I=1,8),PERR,PERS,PERT 00157940 READ (5,620) (N3D(I),I=9,20),INCR,INCS,INCT 00157950 610 FORMAT(8I5,3F10.0) 00157960 620 FORMAT(16I5) 00157970 IF(INCR.LE.0) INCR=1 00157980 NUMDR=(N3D(4)-N3D(1))/INCR+1 00157990 IF(INCS.LE.0) 00158000 $INCS=N3D(4)-N3D(1)+1 00158010 NUMDS=(N3D(3)-N3D(4))/INCS+1 00158020 IF(INCT.LE.0) 00158030 $INCT=N3D(3)-N3D(1)+1 00158040 NUMDT=(N3D(7)-N3D(3))/INCT+1 00158050 IF(PERR.LE.0.0)PERR=100.0 00158060 IF(PERS.LE.0.0)PERS=100.0 00158070 IF(PERT.LE.0.0)PERT=100.0 00158080 WRITE(6,630)(N3D(I),I=1,8),(N3D(I),I=9,20),INCR,INCS,INCT,PERR 00158090 $,PERS,PERT 00158100 630 FORMAT(//20X,28HVOLUME COORDINATE GENERATION 00158110 $ /20X,27HNODE NOS. FOR CORNERS 1-8 =,1X,8I5 00158120 $ /20X,28HNODE NOS. FOR CORNERS 9-20 =,1X,12I5 00158130 $ /20X,35HNODE INCREMENT IN THE R DIRECTION =,1X,I5 00158140 $ /20X,35HNODE INCREMENT IN THE S DIRECTION =,1X,I5 00158150 $ /20X,35HNODE INCREMENT IN THE T DIRECTION =,1X,I5 00158160 $ /20X,38HREFINEMENT FACTOR IN THE R DIRECTION =,1X,F15.5 00158170 $ /20X,38HREFINEMENT FACTOR IN THE S DIRECTION =,1X,F15.5 00158180 $ /20X,38HREFINEMENT FACTOR IN THE T DIRECTION =,1X,F15.5//)00158190 DO 680 I=1,20 00158200 J=N3D(I) 00158210 IF(J.GE.0.AND.J.LE.NUMNP) GO TO 650 00158220 WRITE(6,440)N3D(I) 00158230 KSKIP=1 00158240 GO TO 220 00158250 650 DO 660 K=1,3 00158260 660 CORD(I,K)=0.0 00158270 IF(J.EQ.0) GO TO 680 00158280 DO 670 K=1,3 00158290 NNN=ID(J,K) 00158300 IF(NNN.LT.0) NNN=NNN-1 00158310 670 CORD(I,K)=(ID(J,K)-NNN-XAD)*XMX 00158320 680 CONTINUE 00158330 NI=8 00158340 DO 690 I=9,20 00158350 IF(N3D(I).GT.0) NI=20 00158360 690 H(I)=0.0 00158370 DO 700 I=1,8 00158380 IF(N3D(I).EQ.0) WRITE(6,510)I 00158390 IF(N3D(I).EQ.0) GO TO 220 00158400 700 CONTINUE 00158410 NNN=NUMDR*INCR*NUMDS+(INCS-NUMDR*INCR)*(NUMDS-1) 00158420 NNN=N3D(1)+NNN*NUMDT+(INCT-NNN)*(NUMDT-1)-INCR 00158430 IF(NNN.NE.N3D(7)) WRITE(6,720) 00158440 IF(NNN.NE.N3D(7))GO TO 220 00158450 720 FORMAT(//20X,37HVOLUME GENERATION IS BEING TERMINATED, 00158460 $ /20X,40HCHECK NODE NOS. ON CORNERS 1,3,4, AND 7.//) 00158470 PERR=PERR/100.0 00158480 PERS=PERS/100.0 00158490 PERT=PERT/100.0 00158500 T=-1. 00158510 LLL=NUMDR-2 00158520 SUMR=1.0 00158530 DO 730 I=1,LLL 00158540 730 SUMR=SUMR+PERR**I 00158550 LLL=NUMDS-2 00158560 SUMS=1.0 00158570 DO 740 I=1,LLL 00158580 740 SUMS=SUMS+PERS**I 00158590 LLL=NUMDT-2 00158600 SUMT=1.0 00158610 DO 750 I=1,LLL 00158620 750 SUMT=SUMT+PERT**I 00158630 IF(PERR.EQ.1.0) SUMR=NUMDR-1 00158640 IF(PERS.EQ.1.0) SUMS=NUMDS-1 00158650 IF(PERT.EQ.1.0) SUMT=NUMDT-1 00158660 FACTT=1.0/PERT 00158670 NODE=N3D(1) 00158680 DR=2.0/SUMR 00158690 DS=2.0/SUMS 00158700 DT=2.0/SUMT 00158710 DO 820 MMM=1,NUMDT 00158720 NODEI=NODE 00158730 S=-1. 00158740 FACTS=1.0/PERS 00158750 DO 810 I=1,NUMDS 00158760 R=-1. 00158770 FACTR=1.0/PERR 00158780 DO 800 J=1,NUMDR 00158790 RP=1.+R 00158800 SP=1.+S 00158810 TP=1.+T 00158820 RM=1.-R 00158830 SM=1.-S 00158840 TM=1.-T 00158850 IF(NI.NE.20) GO TO 760 00158860 RR=1.-R*R 00158870 SS=1.-S*S 00158880 TT=1.-T*T 00158890 IF(N3D(9).GT.0) 00158900 $H(9)=RM*SS*TM*0.25 00158910 IF(N3D(10).GT.0) 00158920 $H(10)=RR*SP*TM*0.25 00158930 IF(N3D(11).GT.0) 00158940 $H(11)=RP*SS*TM*0.25 00158950 IF(N3D(12).GT.0) 00158960 $H(12)=RR*SM*TM *0.25 00158970 IF(N3D(13).GT.0) 00158980 $H(13)=RM*SS*TP*0.25 00158990 IF(N3D(14).GT.0) 00159000 $H(14)=RR*SP*TP*0.25 00159010 IF(N3D(15).GT.0) 00159020 $H(15)=RP*SS*TP*0.25 00159030 IF(N3D(16).GT.0) 00159040 $H(16)=RR*SM*TP*0.25 00159050 IF(N3D(17).GT.0) 00159060 $H(17)=RM*SM*TT*0.25 00159070 IF(N3D(18).GT.0) 00159080 $H(18)=RM*SP*TT *0.25 00159090 IF(N3D(19).GT.0) 00159100 $H(19)=RP*SP*TT*0.25 00159110 IF(N3D(20).GT.0) 00159120 $H(20)=RP*SM*TT*0.25 00159130 760 TM=0.125*TM 00159140 TP=0.125*TP 00159150 H(1)=RM*SM*TM -0.5*(H( 9)+H(17)+H(12)) 00159160 H(2)=RM*SP*TM -0.5*(H( 9)+H(18)+H(10)) 00159170 H(3)=RP*SP*TM -0.5*(H(10)+H(19)+H(11)) 00159180 H(4)=RP*SM*TM -0.5*(H(11)+H(20)+H(12)) 00159190 H(5)=RM*SM*TP -0.5*(H(13)+H(17)+H(16)) 00159200 H(6)=RM*SP*TP -0.5*(H(13)+H(18)+H(14)) 00159210 H(7)=RP*SP*TP -0.5*(H(14)+H(19)+H(15)) 00159220 H(8)=RP*SM*TP -0.5*(H(15)+H(20)+H(16)) 00159230 DO 770 JJ=1,3 00159240 770 CZ(JJ)=0.0 00159250 DO 780 II=1,NI 00159260 DO 780 JJ=1,3 00159270 780 CZ(JJ)=CZ(JJ)+H(II)*CORD(II,JJ) 00159280 DO 790 JJ=1,3 00159290 790 ID(NODE,JJ)=CZ(JJ)/XMX+XAD 00159300 NODE=NODE+INCR 00159310 FACTR=FACTR*PERR 00159320 800 R=R+DR*FACTR 00159330 NODE=NODE-NUMDR*INCR+INCS 00159340 FACTS=FACTS*PERS 00159350 810 S=S+DS*FACTS 00159360 NODE=NODEI+INCT 00159370 FACTT=FACTT*PERT 00159380 820 T=T+DT*FACTT 00159390 IF(KS.NE.0) CALL VOLM(N3D,INCR,INCS,INCT,NUMDR,NUMDS, 00159400 $NUMDT,XAD,XMX,NZZ,ID,KS,CORD) 00159410 GO TO 220 00159420 END 00159430 SUBROUTINE CONVER (KS,KT) 00051120 IMPLICIT REAL*8(A-H,O-Z) 00051130 COMMON/QTSARG/ X(3,50),Y(3,50),Z(3,50),TI(3,3,50),XC(3),XI(3) 00051140 & ,RRQTSA(94) R0051141 DIMENSION XX(3) 00051150 RDN=0.01745329251 00051160 GO TO (100,120,130),KT 00051170 100 DO 110 I=1,3 00051180 110 XC(I)=XI(I) 00051190 GO TO 140 00051200 120 THETA=XI(2)*RDN 00051210 PHI=XI(3)*RDN 00051220 R=XI(1) 00051230 XC(1)=R* DSIN(PHI)* DCOS(THETA) 00051240 XC(2)=R* DSIN(PHI)* DSIN(THETA) 00051250 XC(3)=R* DCOS(PHI) 00051260 GO TO 140 00051270 130 THETA=XI(2)*RDN 00051280 XC(1)=XI(1)* DCOS(THETA) 00051290 XC(2)=XI(1)* DSIN(THETA) 00051300 XC(3)=XI(3) 00051310 140 IF(KS.EQ.0) RETURN 00051320 DO 150 I=1,3 00051330 XX(I)=0.0 00051340 DO 150 J=1,3 00051350 150 XX(I)=XX(I)+TI(J,I,KS)*XC(J) 00051360 XC(1)=XX(1)+X(1,KS) 00051370 XC(2)=XX(2)+Y(1,KS) 00051380 XC(3)=XX(3)+Z(1,KS) 00051390 RETURN 00051400 END 00051410 SUBROUTINE SRFC (NOD,INCS,INCT,NUMDS,NUMDT,XAD,XMX,NZZ,ID,KS,CORD)00254700 IMPLICIT REAL*8 (A-H,O-Z) 00254710 REAL*8 ID(NZZ,3) 00254720 DIMENSION NOD(8),NN(4),CORD(20,3),NIB(4) 00254730 DIMENSION P1(3),P2(3),P3(3),P4(3),P5(3),P6(3),P7(3),P8(3) 00254740 DATA NIB/1,2,4,1/ 00254750 IF (KS.GT.3 .OR. KS.LT.-4) GO TO 500 00254760 IF (KS.LT.0) GO TO 300 00254770 READ (5,10) NN 00254780 10 FORMAT (4I5) 00254790 DO 20 I=1,4 00254800 J=NN(I) 00254810 IF (J.LE.0) GO TO 20 00254820 DO 15 K=1,3 00254830 NNN=ID(J,K) 00254840 IF (NNN.LT.0) NNN=NNN-1 00254850 15 CORD(I,K)=(ID(J,K)-NNN-XAD)*XMX 00254860 20 CONTINUE 00254870 GO TO (22,100,200), KS 00254880 22 CONTINUE 00254890 RAD=CORD(2,1) 00254900 DO 25 K=1,3 00254910 25 P1(K)=CORD(1,K) 00254920 NODE=NOD(1) 00254930 DO 50 I=1,NUMDT 00254940 DO 40 J=1,NUMDS 00254950 DO 30 K=1,3 00254960 NNN=ID(NODE,K) 00254970 IF (NNN.LT.0) NNN=NNN-1 00254980 30 P2(K)=(ID(NODE,K)-NNN-XAD)*XMX 00254990 CALL PTS1 (P1,P2,RAD,P3) 00255000 DO 35 K=1,3 00255010 35 ID(NODE,K)=P3(K)/XMX+XAD 00255020 NODE=NODE+INCS 00255030 40 CONTINUE 00255040 NODE=NODE-NUMDS*INCS+INCT 00255050 50 CONTINUE 00255060 GO TO 500 00255070 100 CONTINUE 00255080 RAD=CORD(3,1) 00255090 DO 125 K=1,3 00255100 P1(K)=CORD(1,K) 00255110 125 P2(K)=CORD(2,K) 00255120 NODE=NOD(1) 00255130 DO 150 I=1,NUMDT 00255140 DO 140 J=1,NUMDS 00255150 DO 130 K=1,3 00255160 NNN=ID(NODE,K) 00255170 IF (NNN.LT.0) NNN=NNN-1 00255180 130 P3(K)=(ID(NODE,K)-NNN-XAD)*XMX 00255190 CALL PTS2 (P1,P2,P3,A,B,C,D) 00255200 CALL PTS3 (P1,P2,A,B,C,D,P4) 00255210 CALL PTS1 (P4,P3,RAD,P5) 00255220 DO 135 K=1,3 00255230 135 ID(NODE,K)=P5(K)/XMX+XAD 00255240 NODE=NODE+INCS 00255250 140 CONTINUE 00255260 NODE=NODE-NUMDS*INCS+INCT 00255270 150 CONTINUE 00255280 GO TO 500 00255290 200 CONTINUE 00255300 DO 225 K=1,3 00255310 P1(K)=CORD(1,K) 00255320 P2(K)=CORD(2,K) 00255330 P3(K)=CORD(3,K) 00255340 225 P4(K)=CORD(4,K) 00255350 NODE=NOD(1) 00255360 DO 250 I=1,NUMDT 00255370 DO 240 J=1,NUMDS 00255380 DO 230 K=1,3 00255390 NNN=ID(NODE,K) 00255400 IF (NNN.LT.0) NNN=NNN-1 00255410 230 P5(K)=(ID(NODE,K)-NNN-XAD)*XMX 00255420 CALL PTS2 (P1,P2,P5,A,B,C,D) 00255430 CALL PTS3 (P1,P2,A,B,C,D,P6) 00255440 CALL PTS3 (P3,P4,A,B,C,D,P7) 00255450 RAD=DSQRT((P7(1)-P6(1))**2+(P7(2)-P6(2))**2+(P7(3)-P6(3))**2) 00255460 CALL PTS1 (P6,P5,RAD,P8) 00255470 DO 235 K=1,3 00255480 235 ID(NODE,K)=P8(K)/XMX+XAD 00255490 NODE=NODE+INCS 00255500 240 CONTINUE 00255510 NODE=NODE-NUMDS*INCS+INCT 00255520 250 CONTINUE 00255530 GO TO 500 00255540 300 CONTINUE 00255550 KS=IABS(KS) 00255560 DO 400 N=1,KS 00255570 READ (5,10) NS, (NN(I),I=1,3) 00255580 IF (NS.LT.1 .OR. NS.GT.4) GO TO 400 00255590 DO 320 I=1,3 00255600 J=NN(I) 00255610 DO 320 K=1,3 00255620 NNN=ID(J,K) 00255630 IF (NNN.LT.0) NNN=NNN-1 00255640 320 CORD(I,K)=(ID(J,K)-NNN-XAD)*XMX 00255650 RAD=CORD(3,1) 00255660 DO 325 K=1,3 00255670 P1(K)=CORD(1,K) 00255680 325 P2(K)=CORD(2,K) 00255690 M=NIB(NS) 00255700 NODE=NOD(M) 00255710 INC=INCS 00255720 IF (NS.EQ.2 .OR. NS.EQ.4) INC=INCT 00255730 NUMD=NUMDS 00255740 IF (NS.EQ.2 .OR. NS.EQ.4) NUMD=NUMDT 00255750 DO 380 M=1,NUMD 00255760 DO 335 K=1,3 00255770 NNN=ID(NODE,K) 00255780 IF (NNN.LT.0) NNN=NNN-1 00255790 335 P3(K)=(ID(NODE,K)-NNN-XAD)*XMX 00255800 CALL PTS2 (P1,P2,P3,A,B,C,D) 00255810 CALL PTS3 (P1,P2,A,B,C,D,P4) 00255820 CALL PTS1 (P4,P3,RAD,P5) 00255830 DO 340 K=1,3 00255840 340 ID(NODE,K)=P5(K)/XMX+XAD 00255850 NODE=NODE+INC 00255860 380 CONTINUE 00255870 400 CONTINUE 00255880 500 RETURN 00255890 END 00255900 SUBROUTINE VOLM (N3D,INCR,INCS,INCT,NUMDR,NUMDS,NUMDT,XAD,XMX, 00320250 $ NZZ,ID,KS,CORD) 00320260 IMPLICIT REAL*8 (A-H,O-Z) 00320270 REAL*8 ID(NZZ,3) 00320280 DIMENSION N3D(20),NN(4),CORD(20,3),NIB(6) 00320290 DIMENSION P1(3),P2(3),P3(3),P4(3),P5(3),P6(3),P7(3),P8(3) 00320300 DATA NIB/1,4,2,1,5,1/ 00320310 IF (KS.LT.0 .OR. KS.GT.6) GO TO 600 00320320 DO 500 N=1,KS 00320330 READ (5,2) NS,NTYP,NN 00320340 2 FORMAT (6I5) 00320350 IF (NS.LT.1 .OR. NS.GT.6) GO TO 500 00320360 IF (NTYP.LT.1 .OR. NTYP.GT.3) GO TO 500 00320370 M=NIB(NS) 00320380 NODE=N3D(M) 00320390 GO TO (10,10,20,20,30,30), NS 00320400 10 NUMD1=NUMDT 00320410 NUMD2=NUMDS 00320420 INC1=INCS 00320430 INC2=INCT 00320440 GO TO 70 00320450 20 NUMD1=NUMDT 00320460 NUMD2=NUMDR 00320470 INC1=INCR 00320480 INC2=INCT 00320490 GO TO 70 00320500 30 NUMD1=NUMDS 00320510 NUMD2=NUMDR 00320520 INC1=INCR 00320530 INC2=INCS 00320540 70 CONTINUE 00320550 DO 90 I=1,4 00320560 J=NN(I) 00320570 IF (J.LE.0) GO TO 90 00320580 DO 80 K=1,3 00320590 NNN=ID(J,K) 00320600 IF (NNN.LT.0) NNN=NNN-1 00320610 80 CORD(I,K)=(ID(J,K)-NNN-XAD)*XMX 00320620 90 CONTINUE 00320630 GO TO (100,200,300), NTYP 00320640 100 CONTINUE 00320650 RAD=CORD(2,1) 00320660 DO 125 K=1,3 00320670 125 P1(K)=CORD(1,K) 00320680 DO 150 I=1,NUMD1 00320690 DO 140 J=1,NUMD2 00320700 DO 130 K=1,3 00320710 NNN=ID(NODE,K) 00320720 IF (NNN.LT.0) NNN=NNN-1 00320730 130 P2(K)=(ID(NODE,K)-NNN-XAD)*XMX 00320740 CALL PTS1 (P1,P2,RAD,P3) 00320750 DO 135 K=1,3 00320760 135 ID(NODE,K)=P3(K)/XMX+XAD 00320770 NODE=NODE+INC1 00320780 140 CONTINUE 00320790 NODE=NODE-NUMD2*INC1+INC2 00320800 150 CONTINUE 00320810 GO TO 500 00320820 200 CONTINUE 00320830 RAD=CORD(3,1) 00320840 DO 225 K=1,3 00320850 P1(K)=CORD(1,K) 00320860 225 P2(K)=CORD(2,K) 00320870 DO 250 I=1,NUMD1 00320880 DO 240 J=1,NUMD2 00320890 DO 230 K=1,3 00320900 NNN=ID(NODE,K) 00320910 IF (NNN.LT.0) NNN=NNN-1 00320920 230 P3(K)=(ID(NODE,K)-NNN-XAD)*XMX 00320930 CALL PTS2 (P1,P2,P3,A,B,C,D) 00320940 CALL PTS3 (P1,P2,A,B,C,D,P4) 00320950 CALL PTS1 (P4,P3,RAD,P5) 00320960 DO 235 K=1,3 00320970 235 ID(NODE,K)=P5(K)/XMX+XAD 00320980 NODE=NODE+INC1 00320990 240 CONTINUE 00321000 NODE=NODE-NUMD2*INC1+INC2 00321010 250 CONTINUE 00321020 GO TO 500 00321030 300 CONTINUE 00321040 DO 325 K=1,3 00321050 P1(K)=CORD(1,K) 00321060 P2(K)=CORD(2,K) 00321070 P3(K)=CORD(3,K) 00321080 325 P4(K)=CORD(4,K) 00321090 DO 350 I=1,NUMD1 00321100 DO 340 J=1,NUMD2 00321110 DO 330 K=1,3 00321120 NNN=ID(NODE,K) 00321130 IF (NNN.LT.0) NNN=NNN-1 00321140 330 P5(K)=(ID(NODE,K)-NNN-XAD)*XMX 00321150 CALL PTS2 (P1,P2,P5,A,B,C,D) 00321160 CALL PTS3 (P1,P2,A,B,C,D,P6) 00321170 CALL PTS3 (P3,P4,A,B,C,D,P7) 00321180 RAD=DSQRT((P7(1)-P6(1))**2+(P7(2)-P6(2))**2+(P7(3)-P6(3))**2) 00321190 CALL PTS1 (P6,P5,RAD,P8) 00321200 DO 335 K=1,3 00321210 335 ID(NODE,K)=P8(K)/XMX+XAD 00321220 NODE=NODE+INC1 00321230 340 CONTINUE 00321240 NODE=NODE-NUMD2*INC1+INC2 00321250 350 CONTINUE 00321260 500 CONTINUE 00321270 600 CONTINUE 00321280 RETURN 00321290 END 00321300 SUBROUTINE PTS1 (P1,P2,R,P3) IMPLICIT REAL*8 (A-H,O-Z) 00183050 DIMENSION P1(3),P2(3),P3(3) 00183060 DX=P2(1)-P1(1) 00183070 DY=P2(2)-P1(2) 00183080 DZ=P2(3)-P1(3) 00183090 DEN=DSQRT(DX*DX+DY*DY+DZ*DZ) 00183100 COSA=DX/DEN 00183110 COSB=DY/DEN 00183120 COSC=DZ/DEN 00183130 P3(1)=R*COSA+P1(1) 00183140 P3(2)=R*COSB+P1(2) 00183150 P3(3)=R*COSC+P1(3) 00183160 RETURN 00183170 END 00183180