PROGRAM DRIVER C * * * * * * * * * * * * * * * * * * * * * * * * * C DUMMY MAIN TO SET PROGRAM CAPACITY LIMITS: C C TO INCREASE MEMORY STORAGE SIZE CHANGE PARAMETER C MAXR FOR REAL ARRAYS AND/OR C MAXI FOR INTEGER ARRAYS C C TO INCREASE THE NUMBER OF ARRAY NAMES & SIZES CHANGE C NUMR FOR REAL ARRAYS AND/OR C NUMI FOR INTEGER ARRAYS C C ERROR MESSAGES WILL STATE WHEN THESE ARE NECESSARY C * * * * * * * * * * * * * * * * * * * * * * * * * CHARACTER*8 RN, IN PARAMETER (NUMR= 55, MAXR= 55000) PARAMETER (NUMI= 25, MAXI= 5000) DIMENSION R(MAXR), RN(NUMR), I(MAXI), IN(NUMI) DIMENSION J(NUMR), K(NUMI) C C USER ACCESS VIA COMMON IS ALLOWED. STANDARD ACCESS IS C ALWAYS VIA DUMMY DIMENSION ARGUMENTS C COMMON / REAL / R, RN, MMAXR, NNUMR, LLASTR, J COMMON / INTEGER / MMAXI, NNUMI, LLASTI, I, IN, K C C I = VECTOR HOLDING ALL INTEGER ARRAYS (APPENDABLE) C IN = NAMES OF EACH INTEGER ARRAY (APPENDABLE) C J = POINTER TO BEGINNING OF EACH REAL ARRAY (APPENDABLE) C K = POINTER TO BEGINNING OF EACH INTEGER ARRAY (APPENDABLE) C LASTI = NUMBER OF THE LAST ASSIGNED INTEGER ARRAY C LASTR = NUMBER OF THE LAST ASSIGNED REAL ARRAY C LLASTI = NUMBER OF THE LAST ASSIGNED INTEGER ARRAY (COMMON) C LLASTR = NUMBER OF THE LAST ASSIGNED REAL ARRAY (COMMON) C MAXI = STORAGE ALLOWED FOR ALL INTEGER ARRAYS C MAXR = STORAGE ALLOWED FOR ALL REAL ARRAYS C MMAXI = STORAGE ALLOWED FOR ALL INTEGER ARRAYS (COMMON) C MMAXR = STORAGE ALLOWED FOR ALL REAL ARRAYS (COMMON) C NNUMI = ALLOWED NUMBER OF INTEGER ARRAYS (VIA COMMON) C NNUMR = ALLOWED NUMBER OF REAL ARRAYS (VIA COMMON) C NUMI = ALLOWED NUMBER OF INTEGER ARRAYS C NUMR = ALLOWED NUMBER OF REAL ARRAYS C R = VECTOR HOLDING ALL REAL ARRAYS (APPENDABLE) C RN = NAMES OF EACH REAL ARRAY (APPENDABLE) C C ALLOW ACCESS VIA COMMON FOR USER APPLICATIONS (NOT USED) MMAXR = MAXR MMAXI = MAXI NNUMR = NUMR NNUMI = NUMI LLASTI = 0 LLASTR = 0 C C BUILD DYNAMIC DIMENSION STORAGES AND EXECUTE MODEL CALL DYNDIM (NUMR, MAXR, NUMI, MAXI, R, RN, I, IN, 1 J, K ) C NOTE: DYNDIM IS ESSENTIALLY WRITTEN BY PROGRAM DIMMAK.F C USING ARRAYS "REALS" AND "INTEGERS", THEN EDITED C TO REMOVE BLANKS, ETC. IT ALSO WRITES MODEL CALL C AND DIMENSION STATEMENTS STOP 'NORMAL END' END Subroutine notation C ...................... NOTATION ...................... C C AD = VECTOR CONTAINING FLOATING POINT VARIABLES C AJ = JACOBIAN MATRIX C AJINV = INVERSE JACOBIAN MATRIX C C B = STRAIN-DISPLACEMENT (GRADIENT) MATRIX C BODY = BODY FORCE VECTOR C C C = ELEMENT COLUMN MATRIX C CB = BOUNDARY SEGMENT COLUMN MATRIX C CC = COLUMN MATRIX OF SYSTEM EQUATIONS C CEQ = CONSTRAINT EQS COEFFS ARRAY C COORD = SPATIAL COORDINATES OF A SELECTED SET OF NODES C CP = PENALTY CONSTRAINT COLUMN MATRIX C CUTOFF = NUMBER FOR CUTTING OFF ITERATIONS C C D = NODAL PARAMETERS ASSOCIATED WITH A GIVEN ELEMENT C DD = SYSTEM LIST OF NODAL PARAMETERS C DGH = GLOBAL DERIV.S OF INTERPOLATION FUNCTIONS H C DDOLD = SYSTEM LIST OF NODAL DOF FROM LAST ITERATION C DLG = LOCAL DERIVATIVES OF GEOMETRY FUNCTIONS G C DLH = LOCAL DERIVATIVES OF INTERPOLATION FUNCTIONS H C C E = CONSTITUTIVE MATRIX C EB = PRODUCT OF E AND B C ELPROP = ELEMENT ARRAY OF FLOATING POINT PROPERTIES C C FLTNP = REAL PROPERTIES OF SYSTEM NODES C FLTEL = SYSTEM STORAGE OF FLOATING PT ELEMENT PROP C FLTMIS = SYSTEM STORAGE OF FLOATING PT MISC. PROP C FLTNP = SYSTEM STORAGE OF FLOATING PT NODAL PROP C FLUX = SPATIAL COMPONENTS OF SPECIFIED BOUNDARY FLUX C C G = INTERPOLATION FUNCTIONS FOR GEOMETRY C GLOBAL = GLOBAL DERIV.S OF INTERPOLATION FUNCTIONS H C C H = INTERPOLATION FUNCTIONS FOR AN ELEMENT SOLUTION C HINTG = INTEGRAL OF INTERPOLATION FUNCTIONS C C IBC = NODAL POINT BOUNDARY RESTRAINT INDICATOR ARRAY C ID = VECTOR CONTAINING FIXED POINT ARRAYS C IDIAG = DIAGONAL LOCATION IN SKYLINE VECTOR C INDEX = SYSTEM DEGREE OF FREEDOM NUMBERS ARRAY C INRHS > 0, IF INITIAL VALUES OF CC ARE INPUT C IPTEST > 0, IF SOME PROPERTIES ARE DEFINED C ISAY = NO. OF USER REMARKS TO BE I/O C C KFIXED = ALLOCATED SIZE OF ARRAY ID C KFLOAT = ALLOCATED SIZE OF ARRAY AD C KODES = LIST OF DOF RESTRAINT INDICATORS AT A NODE C K1-K5 = NO. OF COLUMNS OF FLOATING PT CONSTRAINT DATA C C LBN = NUMBER OF NODES ON AN ELEMENT BOUNDARY SEGMENT C LEMWRT = 0, IF LIST NODAL PARAMETERS BY ELEMENTS C LHOMO = 1, IF ELEMENT PROPERTIES ARE HOMOGENEOUS C LNODE = THE N ELEMENT INCIDENCES OF THE ELEMENT C LPFIX = SYSTEM STORAGE ARRAY FOR FIXED PT ELEMENT PROP C LPROP = ARRAY OF FIXED POINT ELEMENT PROPERTIES C LPTEST > 0, IF ELEMENT PROPERTIES ARE DEFINED C C LPPROP = INTEGER PROPERTIES AT EACH ELEMENT NODE C LPROP = ARRAY INTEGER ELEMENT PROPERTIES C LPTEST > 0, IF ELEMENT PROPERTIES HAVE BEEN DEFINED C M = NUMBER OF SYSTEM NODES C MAXACT = NO ACTIVE CONSTRAINT TYPES (<=MAXTYP) C MAXBAN = MAX. HALF BANDWIDTH OF SYSTEM EQUATIONS C MAXTIM > 0, CALCULATE CPU TIMES OF MAJOR SEGMENTS C MAXTYP = MAX NODAL CONSTRAINT TYPE (=3 NOW) C MISCFL = NO. MISC. FLOATING POINT SYSTEM PROPERTIES C MISCFX = NO. MISC. FIXED POINT SYSTEM PROPERTIES C MISFIX = SYSTEM ARRAY OF MISC. FIXED POINT PROPERTIES C MODE = MODE OF STORAGE, 0-SKYLINE, 1-BANDED C MTOTAL = REQUIRED SIZE OF ARRAY AD C M1 TO MNEXT = POINTERS FOR FLOATING POINT ARRAYS C C N = NUMBER OF NODES PER ELEMENT C NCURVE = NO. CONTOUR CURVES CALCULATED PER PARAMETER C NDFREE = TOTAL NUMBER OF SYSTEM DEGREES OF FREEDOM C NDXC = CONSTRAINT EQS DOF NUMBERS ARRAY C NE = NUMBER OF ELEMENTS IN SYSTEM C NELFRE = NUMBER OF DEGREES OF FREEDOM PER ELEMENT C NG = NUMBER OF NODAL PARAMETERS (DOF) PER NODE C NGEOM = NUMBER OF GEOMETRY NODES C NHOMO > 0, IF NODAL SYSTEM PROPERTIES ARE HOMOGENEOUS C NITER = NO. OF ITERATIONS TO BE RUN C NLPFIX = NO. FIXED POINT ELEMENT PROPERTIES C NLPFLO = NO. FLOATING POINT ELEMENT PROPERTIES C NMAT = NUMBER OF MATERIAL TYPES C NNPFIX = NO. FIXED POINT NODAL PROPERTIES C NNPFLO = NO. FLOATING POINT NODAL PROPERTIES C NOCOEF = NO COEFF IN SYSTEM SQ MATRIX C NODES = ELEMENT INCIDENCES OF ALL ELEMENTS C NOTHER = TOTAL NO. OF BOUNDARY RESTRAINTS .GT. TYPE1 C NPARM = DIMENSION OF PARAMWETRIC SPACE C NPFIX = INTEGER PROPERTIES AT ALL NODES C NPROP = NODAL ARRAY OF FIXED POINT PROPERTIES C NPTWRT = 0, LIST NODAL PARAMETERS BY NODES C NQP = NUMBER OF QUADRATURE POINTS C NRANGE = ARRAY CONTAINING NODE NO.S OF EXTREME VALUES C NRB = NUMBER OF ROWS IN B AND E MATRICES C NREQ = NO. OF CONSTRAINT EQS. OF EACH TYPE C NRES = NO. OF CONSTRAINT FLAGS OF EACH TYPE C NSEG = NO OF ELEM BOUNDARY SEGMENTS WITH GIVEN FLUX C NSPACE = DIMENSION OF SPACE C NTAPE1 = UNIT FOR POST SOLUTION MATRICES STORAGE C NTAPE2,3,4 = OPTIONAL UNITS FOR USER (USED WHEN > 0) C NTOTAL = REQUIRED SIZE OF ARRAY ID C NULCOL > 0, IF ELEMENT COLUMN MATRIX IS ALWAYS ZERO C NUMCE = NUMBER OF CONSTRAINT EQS C N1 TO NNEXT = POINTERS FOR FIXED POINT ARRAYS C C PTPROP = NODAL ARRAY OF FLOATING PT PROPERTIES C PRTMAT = REAL ELEM PROPERTIES BASED ON MATERIAL NUMBER C PT = QUADRATURE COORDINATES C PRTLPT = FLOATING PT PROP ARRAY OF ELEMENT'S NODES C C RANGE: 1-MAXIMUM VALUE, 2-MINIMUM VALUE OF DOF C C S = ELEMENT SQUARE MATRIX C SB = BOUNDARY SEGMENT SQUARE MATRIX C SS = 'SQUARE' MATRIX OF SYSTEM EQUATIONS C STRAIN = STRAIN OR GRADIENT VECTOR C STRAN0 = INITIAL STRAIN OR GRADIENT VECTOR C STRESS = STRESS VECTOR C C TIME = ARRAY STORING CPU TIMES FOR VARIOUS SEGMENTS C TITLE = PROBLEM TITLE C C USEREL = (USER CHOICE) ELEMENT APPLICATION RESULT C USERPT = (USER CHOICE) NODAL APPLICATION RESULT C C WT = QUADRATURE WEIGHTS C C X = COORDINATES OF SYSTEM NODES C XYZ = SPACE COORDINATES AT A POINT C X = SPATIAL COORDINATES OF ALL NODES IN THE SYSTEM C XPT = SPATIAL COORDINATES OF A CONTOUR POINT C C ...................................................... return end SUBROUTINE APLYBC (MAXACT, NUMCE, NREQ, CEQ, NDXC, 1 NDFREE, NCOEFF, SS, CC, IBW, 2 IDIAG, MODE ) C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C APPLY BOUNDARY CONSTRAINT EQUATIONS C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8 (A-H,O-Z) DIMENSION SS(NCOEFF), CC(NDFREE), NREQ(MAXACT), 1 CEQ(MAXACT,NUMCE), NDXC(MAXACT,NUMCE), 2 IDIAG(NDFREE) C CC = SYS. EQ. COL. MATRIX C CEQ(I,J) = CONSTRAINT EQS COEFF I FOR EQ J C IBW = CURRENT BAND, GROWS WITH CONSTRAINTS C IDIAG = SKY DIAGONAL POINTER FOR EACH DOF C MAXBAN = MAX. HALF-BANDWIDTH OF SYSTEM EQUATIONS C MODE = STORAGE MODE, 0-SKY, 1-BANDED C NCOEFF = NUMBER OF COEFFICIENTS IN SS C NDFREE = TOTAL NUMBER OF SYSTEM DEGREES OF FREEDOM C NDXC(I,J) = CONSTRAINT EQS DOF NO I FOR EQ J C NG = NO. PARAMETERS PER NODE C NREQ = NO OF CONSTRAINT EQS OF EACH TYPE C NUMCE = NUMBER OF CONSTRAINT EQUATIONS C SS = SYS. EQ. SQ. MATRIX IF ( MODE .EQ. 0 ) THEN C SKYLINE MODE c CALL SKYBC (MAXACT, NUMCE, NREQ, CEQ, NDXC, c 1 NDFREE, NCOEFF, SS, CC, IDIAG ) ELSE C BANDED MODE MAXBAN = NCOEFF/NDFREE CALL BANDBC (MAXACT, NUMCE, NREQ, CEQ, NDXC, 1 NDFREE, MAXBAN, SS, CC, IBW ) ENDIF RETURN END SUBROUTINE ASYMBL (NG, NCOEFF, MODE, IDIAG, NODES, SS, CC, 1 M, NE, NDFREE, NITER, LPTEST, LHOMO, NHOMO, NULCOL, N, 2 NSPACE, NELFRE, NRB, NQP, NGEOM, NPARM, NNPFIX, NNPFLO, 3 MISCFX, MISCFL, NLPFIX, NLPFLO, LNODE, INDEX, X, DDOLD, 4 COORD, S, C, H, DGH, B, E, EB, STRAIN, STRAN0, STRESS, 5 BODY, PT, WT, XYZ, DLH, G, DLG, AJ, AJINV, HINTG, D, 6 PRTLPT, FLTNP, FLTEL, FLTMIS, ELPROP, PRTMAT, 7 MISFIX, NPFIX, LPFIX, LPROP, LPPROP, NTAPE1, NTAPE2, 8 NTAPE3, NTAPE4, NTAPE5, LTYPE, NLTYPE, LTDATA, LSHAPE, 9 GPT, GWT ) C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C ASSEMBLE SYSTEM EQUATIONS AND STORE POST C SOLUTION ELEMENT DATA C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8 (A-H,O-Z) DATA LASTLT, LTFREE / 0, 0 / DIMENSION CC(NDFREE), SS(NCOEFF), IDIAG(NDFREE), NODES(NE,N), 1 LTYPE(NE), LTDATA(6,NLTYPE) C JUST PASSING THROUGH: SYSTEM DATA DIMENSION X(M,NSPACE), DDOLD(NDFREE), LNODE(N), INDEX(NELFRE) C SYSTEM PROPERTIES DIMENSION PRTLPT(N,0:NNPFLO), FLTNP(M,0:NNPFLO), 1 FLTEL(NE,0:NLPFLO), NPFIX(M,0:NNPFIX), 2 LPFIX(NE,0:NLPFIX) C FOR USE IN ELSQ, ELCOL, OR ELPOST: cb 1 H(N,0:NQP), DGH(NSPACE,N), B(NRB,NELFRE), cb 4 PT(NPARM,0:NQP), WT(0:NQP), DLH(NSPACE,N,0:NQP), cb 7 HINTG(N,0:NQP+1), GPT(0:NQP), GWT(0:NQP), DIMENSION COORD(N,NSPACE), S(NELFRE,NELFRE), C(NELFRE), 1 H(nelfre,0:NQP), DGH(NSPACE,nelfre), B(NRB,NELFRE), 2 E(NRB,NRB), EB(NRB,NELFRE), STRAIN(NRB+2), 3 STRAN0(NRB), STRESS(NRB+2), BODY(NSPACE), 4 PT(NPARM,0:NQP), WT(0:NQP), DLH(NSPACE,nelfre,0:NQP), 5 G(NGEOM,0:NQP), DLG(NPARM,NGEOM,0:NQP), 6 AJ(NSPACE,NSPACE), AJINV(NSPACE,NSPACE), 7 HINTG(nelfre,0:NQP+1), GPT(0:NQP), GWT(0:NQP), 8 XYZ(NSPACE), D(NELFRE), FLTMIS(0:MISCFL), 9 ELPROP(0:NLPFLO), PRTMAT(0:NLPFLO), 1 MISFIX(0:MISCFX), LPROP(0:NLPFIX), 2 LPPROP(0:NNPFIX) C VARIABLES: C AJ = JACOBIAN C AJINV = JACOBIAN INVERSE C B = STRAIN-DISPLACEMENT (GRADIENT) MATRIX C BODY = BODY FORCE VECTOR C CC = SYSTEM EQUATIONS COLUMN MATRIX C COORD = SPATIAL COORDINATES OF ELEMENT'S NODES C D = NODAL PARAMETERS ASSOCIATED WITH AN ELEMENT C DDOLD = SYSTEM NODAL PARAMETERS FROM LAST ITERATION C DGH = GLOBAL DERIVATIVES INTERPOLATION FUNCTIONS C DLG = LOCAL DERIVATIVES GEOMETRIC INTERPOLATION C DLH = LOCAL DERIVATIVES INTERPOLATION FUNCTIONS C E = CONSTITUTIVE MATRIX C EB = PRODUCT OF E*B C ELPROP = ELEMENT ARRAY OF REAL PROPERTIES C FLTEL = REAL PROPERTIES OF ELEMENTS C FLTMIS = MISCELLANEOUS REAL PROPERTIES OF SYSTEM C FLTNP = REAL PROPERTIES OF SYSTEM NODES C G = GEOMETRIC INTERPOLATION FUNCTIONS C H = SOLUTION INTERPOLATION FUNCTIONS C HINTG = INTEGRAL OF INTERPOLATION FUNCTIONS C IDIAG = DIAGONAL LOCATION IN SKYLINE VECTOR C INDEX = SYSTEM DOF NUMBERS ASSOCIATED WITH ELEMENT C LHOMO = 1, IF ELEMENT PROPERTIES ARE HOMOGENEOUS C LNODE = THE N ELEMENT INCIDENCES OF THE ELEMENT C LPFIX = SYSTEM ARRAY OF INTEGER ELEM PROPERTIES C LPPROP = INTEGER PROPERTIES AT EACH ELEMENT NODE C LPROP = ARRAY INTEGER ELEMENT PROPERTIES C LPTEST > 0, IF ELEMENT PROPERTIES HAVE BEEN DEFINED C LSHAPE = SHAPE FLAG FOR QUADRATURE RULE SELECTION C LTQP = NUMBER OF QUADRATURE PTS FOR ELEMENT TYPE C LTYPE = ELEMENT TYPE NUMBER C M = NUMBER OF SYSTEM NODES C MODE = MODE OF STORAGE, 0-SKYLINE, 1-BANDED C MISFIX = MISCELLANEOUS INTEGER SYSTEM PROPERTIES C N = NUMBER OF NODES PER ELEMENT C NCOEFF = TOTAL NUMBER OF TERMS IN SS C NDFREE = TOTAL NUMBER OF SYSTEM DEGREES OF FREEDOM C NE = NUMBER OF ELEMENTS C NELFRE = NUMBER OF DEGREES OF FREEDOM PER ELEMENT C NG = NUMBER OF PARAMETERS PER NODE C NGEOM = NUMBER OF GEOMETRY NODES C NHOMO = 1, IF NODAL PROPERTIES ARE HOMOGENEOUS C NITER = NO. OF ITERATIONS TO BE RUN (USUALLY 1) C NMAT = NUMBER OF MATERIAL TYPES C NODES = NODAL INCIDENCES OF ALL ELEMENTS C NPARM = DIMENSION OF PARAMWETRIC SPACE C NPFIX = INTEGER PROPERTIES AT ALL NODES C NQP = NUMBER OF QUADRATURE POINTS, >= LTQP C NRB = NUMBER OF ROWS IN B AND E MATRICES C NSPACE = DIMENSION OF SPACE C NTAPE1 = UNIT FOR POST SOLUTION MATRICES STORAGE C NTAPE2,3,4 = OPTIONAL UNITS FOR USER (USED WHEN > 0) C NULCOL > 0, IF ELEMENT COLUMN MATRIX IS ALWAYS ZERO C PRTLPT = REAL PROPERTIES AT ELEMENT NODES C PRTMAT = REAL ELEM PROPERTIES BASED ON MATERIAL NUMBER C PT = QUADRATURE COORDINATES C S = ELEMENT SQUARE MATRIX C SS = SYSTEM EQUATIONS SQUARE MATRIX C STRAIN = STRAIN OR GRADIENT VECTOR C STRAN0 = INITIAL STRAIN OR GRADIENT VECTOR C STRESS = STRESS VECTOR C WT = QUADRATURE WEIGHTS C X = COORDINATES OF SYSTEM NODES C XYZ = SPACE COORDINATES AT A POINT C c call at (44) c write(6,*) ntape1,ntape2,ntape3,ntape4,ntape5 C GENERATE ELEMENT EQUATIONS & POST SOLUTION MATRICES DO 10 IE = 1, NE C--> GET ELEMENT TYPE NUMBER LT = 1 IF ( NLTYPE .GT. 1 ) LT = LTYPE(IE) C SAME AS LAST TYPE ? IF ( LT .NE. LASTLT ) THEN LASTLT = LT C GET CONTROLS FOR THIS TYPE CALL GETLT (LT, NLTYPE, LTDATA, LTN, LTQP, LTGEOM, 1 LTPARM, LTSHAP, LTUSER ) LTFREE = LTN*NG C--> GET QUADRATURE RULE FOR ELEMENT TYPE AND SHAPE IF ( LTQP .GT. 0 ) THEN IF ( LTQP .GT. NQP ) STOP 'LTQP > NQP IN ASYMBL' CALL GETQD (LTSHAP, LTQP, NSPACE, GPT, GWT, PT, WT) ENDIF ENDIF C--> EXTRACT ELEMENT NODE NUMBERS CALL LNODES (IE, NE, LTN, NODES, LNODE) C--> CALCULATE DEGREE OF FREEDOM NUMBERS CALL INDXEL (LTN, LTFREE, NG, LNODE, INDEX) c print *, 'ie,ltn,ltfree,ng', ie,ltn,ltfree,ng c call iprint(lnode,1,ltn) c call iprint(index,1,ltfree) c call rprint(d,1,ltfree,1) C--> GENERATE ELEMENT PROBLEM DEPENDENT MATRICES CALL GENELM ( IE, M, NE, NDFREE, NITER, LPTEST, LHOMO, 1 NHOMO, NULCOL, LTN, NSPACE, LTFREE, NRB, LTQP, 2 LTGEOM, LTPARM, NNPFIX, NNPFLO, MISCFX, MISCFL, 3 NLPFIX, NLPFLO, LNODE, INDEX, X, DDOLD, COORD, S, 4 C, H, DGH, B, E, EB, STRAIN, STRAN0, STRESS, BODY, 5 PT, WT, XYZ, DLH, G, DLG, AJ, AJINV, HINTG, D, 6 PRTLPT, FLTNP, FLTEL, FLTMIS, ELPROP, 7 PRTMAT, MISFIX, NPFIX, LPFIX, LPROP, LPPROP, 8 NTAPE1, NTAPE2, NTAPE3, NTAPE4, NTAPE5, LT, 9 LTSHAP, LTUSER, NG ) c print *, 'ie,ltn,ltfree,ng', ie,ltn,ltfree,ng c call iprint(lnode,1,ltn) c call iprint(index,1,ltfree) c call rprint(d,1,ltfree,1) C--> STORE THE MATRICES IN SYSTEM EQUATIONS IF ( MODE .EQ. 0 ) THEN C SKYLINE VECTOR STORAGE MODE c CALL SKYSTR (NCOEFF, NDFREE, LTFREE, INDEX, IDIAG, c 1 S, SS) ELSE C BANDED STORAGE MAXBAN = NCOEFF/NDFREE CALL STORSQ (NDFREE, MAXBAN, LTFREE, INDEX, S, SS) ENDIF IF ( NULCOL .EQ. 0 ) 1 CALL STORCL (NDFREE, LTFREE, INDEX, C, CC) 10 CONTINUE C ASSEMBLY COMPLETED RETURN END SUBROUTINE AT (N) WRITE (6,10) N 10 FORMAT(' -------->>> HERE AT ',I8) RETURN END SUBROUTINE BANCHK (NDFREE, MAXBAN, M, NG, S, C) C * * * * * * * * * * * * * * * * * * * * * * * * * C CHECK BANDED SYSTEM FOR INVALID EQUATIONS & WARN C * * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8 (A-H, O-Z) PARAMETER ( NPRT = 6, ZERO = 0.0 ) DIMENSION S(NDFREE,MAXBAN), C(NDFREE) C C = SYSTEM COLUMN MATRIX C S = SYSTEM SQUARE MATRIX IN BANDED MODE C NDFREE = NUMBER OF EQUATIONS C MAXBAN = HALF BANDWIDTH INCLUDING DIAGONAL SMAX = ZERO DO 10 I = 1, NDFREE TEST = ABS( S(I,1) ) IF ( TEST .GT. SMAX ) SMAX = TEST 10 CONTINUE IF ( SMAX .LE. ZERO ) STOP 1 'ALL ELEMENT STIFFENESSES ZERO, BANCHK' K = 0 DO 20 I = 1, M DO 30 J = 1, NG K = K + 1 TEST = S(K,1) IF ( TEST .LE. ZERO ) THEN IF ( TEST .EQ. ZERO ) WRITE (NPRT,200) I, J 200 FORMAT ('WARNING, NODE ',I5,' DOF',I3,' WAS RESTRAINED') IF ( TEST .LT. ZERO ) WRITE (NPRT,300) I, J 300 FORMAT ('ERROR, NODE ',I5,' DOF',I3,' WAS RESTRAINED') CALL MODFY1 (NDFREE, MAXBAN, K, ZERO, S, C) ENDIF 30 CONTINUE 20 CONTINUE RETURN END SUBROUTINE BANDBC (MAXACT, NUMCE, NREQ, CEQ, NDXC, 1 NDFREE, MAXBAN, SS, CC, IBW ) C * * * * * * * * * * * * * * * * * * * * * * * * * * C APPLY BOUNDARY CONSTRAINT EQUATIONS TO BANDED EQS C * * * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8 (A-H,O-Z) DIMENSION SS(NDFREE,MAXBAN), CC(NDFREE), NREQ(MAXACT), 1 CEQ(MAXACT,NUMCE), NDXC(MAXACT,NUMCE) C IBW = CURRENT BAND, GROWS WITH CONSTRAINTS C NDFREE = TOTAL NUMBER OF SYSTEM DEGREES OF FREEDOM C MAXBAN = MAX. HALF-BANDWIDTH OF SYSTEM EQUATIONS C SS = SYS. EQ. SQ. MATRIX C CC = SYS. EQ. COL. MATRIX C NG = NO. PARAMETERS PER NODE C NREQ = NO OF CONSTRAINT EQS OF EACH TYPE C CEQ(I,J) = CONSTRAINT EQS COEFF I FOR EQ J C NDXC(I,J) = CONSTRAINT EQS DOF NO I FOR EQ J C NUMCE = NUMBER OF CONSTRAINT EQUATIONS IEQ = 0 c call iprint(nreq,1,maxact) c call iprint(ndxc,maxact,numce) c call rprint(ceq,maxact,numce,0) C DO TYPE ONE LAST c DO 40 IC = MAXACT,1,-1 DO 40 IC = 1, MAXACT NTEST = NREQ(IC) IF ( NTEST .GT. 0 ) THEN IF ( IC .EQ. 1 ) THEN C--> TYPE 1 D(L1) = C1 DO 10 NEQ = 1, NTEST IEQ = IEQ + 1 L1 = NDXC(1,IEQ) C1 = CEQ(1,IEQ) c write(6,*) NDFREE, MAXBAN, IBW, L1, C1 10 CALL MODFY1 (NDFREE, MAXBAN, L1, C1, SS, CC) ELSEIF ( IC .EQ. 2 ) THEN C--> TYPE 2 D(L1)+C1*D(L2)=C2 DO 20 NEQ = 1, NTEST IEQ = IEQ + 1 L1 = NDXC(1,IEQ) L2 = NDXC(2,IEQ) C1 = CEQ(1,IEQ) C2 = CEQ(2,IEQ) c write(6,*) NDFREE, MAXBAN, IBW, L1, L2, C1, C2 20 CALL MODFY2 (NDFREE, MAXBAN, IBW, L1, L2, C1, C2, 1 SS, CC) ELSEIF ( IC .EQ. 3 ) THEN C--> TYPE 3 D(L1)+C1*D(L2)+C2*D(L3)=C3 DO 30 NEQ = 1,NTEST IEQ = IEQ + 1 L1 = NDXC(1,IEQ) L2 = NDXC(2,IEQ) L3 = NDXC(3,IEQ) C1 = CEQ(1,IEQ) C2 = CEQ(2,IEQ) C3 = CEQ(3,IEQ) 30 CALL MODFY3 (NDFREE, MAXBAN, IBW, L1, L2, L3, C1, 1 C2, C3, SS, CC) ELSEIF ( IC .GT. 3 ) THEN C OTHER TYPES NOT DEFINED STOP 'BANLCE NOT INSTALLED, BANDBC' ENDIF ENDIF 40 CONTINUE RETURN END SUBROUTINE BANMLT (NDFREE, MAXBAN, SS, DD, CC, IOPT) C * * * * * * * * * * * * * * * * * * * * * * * * * * C MULTIPLY PACKED SQUARE MATRIX, SS, BY MATRIX DD C IF IOPT = 0 STORE RESULT IN MATRIX CC C OTHERWISE ADD RESULT TO MATRIX CC C * * * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8 (A-H,O-Z) DIMENSION SS(NDFREE,MAXBAN), DD(NDFREE), CC(NDFREE) C NDFREE = TOTAL NUMBER OF SYSTEM DEGREES OF FREEDOM C MAXBAN = SYSTEM HALF BANDWIDTH MBM1 = MAXBAN - 1 DO 70 I = 1, NDFREE SUM = 0.0 J1 = I - MBM1 J2 = I + MBM1 J1 = MAX0 (J1,1) J2 = MIN0(J2,NDFREE) DO 50 J = J1,J2 IF ( J - I ) 10,20,30 10 JJ = I-J+1 II = J GO TO 40 20 JJ = 1 II = I GO TO 40 30 JJ = J-I+1 II = I 40 SUM = SUM + SS(II,JJ)*DD(J) 50 CONTINUE IF ( IOPT .EQ. 0 ) THEN CC(I) = SUM ELSE CC(I) = CC(I) + SUM ENDIF 70 CONTINUE RETURN END SUBROUTINE BANSUB (I, J, K, L) C * * * * * * * * * * * * * * * * * * * * * * C CONVERT SUBSCRIPTS (I,J) OF SYMMETRIC MATRIX C TO SUBSCRIPTS (K,L) IN UPPER HALF BANDWIDTH C * * * * * * * * * * * * * * * * * * * * * * ITEST = I - J IF ( ITEST ) 10, 20, 30 C BELOW DIAGONAL 10 K = I L = 1 - ITEST RETURN C ON DIAGONAL 20 K = I L = 1 RETURN C ABOVE DIAGONAL 30 K = J L = 1 + ITEST RETURN END SUBROUTINE BAR6T (R, S, T, H, DBH) C * * * * * * * * * * * * * * * * * * * * * * * * * * C BARACENTRIC SHAPES AND DERIVATIVES FOR A T6 ELEMENT C * * * * * * * * * * * * * * * * * * * * * * * * * * PARAMETER ( ZERO = 0.D0, ONE = 1.D0, FOUR = 4.D0 ) DIMENSION H(6), DBH(3,6) C H = SHAPE FUNCTIONS C DBH = BARACENTRIC DERIVATIVES OF H C R,S,T = BARACENTRIC COORDINATES, R+S+T=1 C NODE R S T NODE R S T C 1 1 0 0 4 1/2 1/2 0 3 C 2 0 1 0 5 0 1/2 1/2 6 5 C 3 0 0 1 6 1/2 0 1/2 1 4 2 C SHAPE FUNCTIONS H(1) = R*(R + R - ONE) H(2) = S*(S + S - ONE) H(3) = T*(T + T - ONE) H(4) = FOUR*S*T H(5) = FOUR*R*T H(6) = FOUR*R*S C BARACENTRIC DERIVATIVES DBH(1,1) = FOUR*R - ONE DBH(2,1) = ZERO DBH(3,1) = ZERO DBH(1,2) = ZERO DBH(2,2) = FOUR*S - ONE DBH(3,2) = ZERO DBH(1,3) = ZERO DBH(2,3) = ZERO DBH(3,3) = FOUR*T - ONE DBH(1,4) = ZERO DBH(2,4) = FOUR*T DBH(3,4) = FOUR*S DBH(1,5) = FOUR*T DBH(2,5) = ZERO DBH(3,5) = FOUR*R DBH(1,6) = FOUR*S DBH(2,6) = FOUR*R DBH(3,6) = ZERO RETURN END SUBROUTINE BARPRT (M,NDFREE,NG,NSPACE,IBAR,IPARM, 1 NODIST,X,D,NODBAR) C * * * * * * * * * * * * * * * * * * * * * * * * * * C PRINT-PLOT BAR CHARTS OF NODAL PARAMETER IPARM AT C THE NODES IN ARRAY NODBAR AND SCALE THE RELATIVE C DISTANCE BETWEEN THE POINTS C * * * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8 (A-H,O-Z) PARAMETER ( NPRT = 6, MID = 25, LINE = 2*MID ) DIMENSION X(M,NSPACE), D(NDFREE), NODBAR(IBAR) CHARACTER ALINE(LINE+1), SKIP(LINE+1) cb DIMENSION ALINE(LINE+1), SKIP(LINE+1) CHARACTER*1 BLANK,DOT,DASH,AX,PLUS,A0 DATA BLANK, DOT, DASH, AX, PLUS, A0 1 / ' ', '+', '-', 'X', '+', '0' / DATA NOPLOT / 0 / C M = TOTAL NUMBER OF NODES IN SYSTEM C IPARM = NODAL PARAMETER TO BE GRAPHED,1<=IPARM<=NG C NODBAR = LIST OF NODES TO BE USED (WHEN IBAR.GT.1) C NODIST = 0 OMIT DISTANCES BETWEEN NODAL BAR LINES C X = ARRAY OF GLOBAL COORDINATES OF ALL NODES C NDFREE = TOTAL NO. OF DEGREES OF FREEDOM IN SYSTEM C D = ARRAY OF ALL NODAL PARAMETERS IN THE SYSTEM C NG = NUMBER OF PARAMETERS PER NODE C NSPACE = DIMENSION OF SOLUTION SPACE C IBAR = NUMBER OF NODES TO BE INCLUDED IN BAR CHART C IF IBAR=1 USE ALL NODES , NODBAR NOT USED CDP SQRT(Z) = DSQRT(Z) CDP ABS(Z) = DABS(Z) NOPLOT = NOPLOT + 1 LIMIT = IBAR IF ( IBAR .EQ. 1 ) LIMIT = M WRITE (NPRT,5000) NOPLOT,IPARM,LIMIT 5000 FORMAT (/, '*** PRINT PLOT NUMBER',I3,' ***',/, 1 'NODAL PARAMETER', I3, 2 ', EVALUATED AT ',I5,' NODE POINTS',/) IPMNG = IPARM - NG IF ( NODIST .EQ. 0 ) GO TO 40 C FIND MINIMUM DISTANCE BETWEEN POINTS DMINSQ = 0.0 DO 10 IS = 1,NSPACE 10 DMINSQ = DMINSQ + ( X(2,IS) - X(1,IS) )**2 DO 30 J = 2,LIMIT I = J IF ( IBAR .GT. 1 ) I = NODBAR(J) DTEST = 0.0 DO 20 IS = 1,NSPACE 20 DTEST = DTEST + ( X(I,IS) - X(I-1,IS) )**2 IF ( DTEST .LT. DMINSQ ) DMINSQ = DTEST 30 CONTINUE DMIN = SQRT(DMINSQ) C--> ESTABLISH GRAPH LIMITING VALUES 40 CONTINUE c YMAX = 0.0 C INITALIZE MAX MIN VALUES OF PARAMETER N = 1 IF ( IBAR .NE. 1 ) N = NODBAR(1) INDEX = NG*N + IPMNG YMAX = D(INDEX) YMIN = YMAX DO 50 I = 1,LIMIT N = I IF ( IBAR .NE. 1 ) N = NODBAR(I) c IF ( IBAR .GT. 1 ) N = NODBAR(I) INDEX = NG*N + IPMNG DTEST = D(INDEX) IF ( DTEST .GT. YMAX ) YMAX = DTEST IF ( DTEST .LT. YMIN ) YMIN = DTEST 50 CONTINUE KOUNT = 1 c 60 IF ( YMAX .LT. 10.0 ) GO TO 70 c KOUNT = KOUNT + 1 c YMAX = YMAX*0.1 c GO TO 60 c 70 YSCALE = 10.**KOUNT c IF ( YMAX .LT. 5.0 ) YSCALE = YSCALE*0.5 c IF ( YMAX .LT. 2.0 ) YSCALE = YSCALE*0.4 c IF ( YMAX .LT. 1.0 ) YSCALE = YSCALE*0.05 WRITE (NPRT,5010) YMIN, YMAX 5010 FORMAT (' RANGE ON GRAPH IS ',1PE12.5,' TO ',1PE12.5/) IF ( YMIN .EQ. YMAX ) THEN WRITE (NPRT,5011) 5011 FORMAT ('CONSTANT VALUE, PLOT SKIPPED') RETURN ENDIF RANGE = YMAX - YMIN C SCALING COMPLETE c WRITE (NPRT,5010) YSCALE c5010 FORMAT (' RANGE ON GRAPH IS +/- ',1PE12.5,/) c CONST = FLOAT(LINE)/(YSCALE + YSCALE) DO 80 I = 2,LINE SKIP(I) = BLANK 80 ALINE(I) = DASH SKIP(1) = PLUS SKIP(MID+1) = DOT SKIP(LINE+1) = PLUS DO 90 I = 1,LINE+1,5 90 ALINE(I) = PLUS ALINE(MID+1) = DOT WRITE (NPRT,5020) ALINE 5020 FORMAT(' NODE VALUE ', (101A1) ) c DO 100 I = 2,LINE c 100 ALINE(I) = BLANK N = 1 IF ( IBAR .GT. 1 ) N = NODBAR(1) DO 210 K = 1,LIMIT NLAST = N N = K IF ( IBAR .GT. 1 ) N = NODBAR(K) INDEX = NG*N + IPMNG DTEST = D(INDEX) c JY = ( D(INDEX) + YSCALE )*CONST + 1.4 DO 100 I = 2,LINE 100 ALINE(I) = BLANK ALINE(1) = PLUS c ALINE(MID+1) = DOT ALINE(LINE+1) = PLUS IF ( JZ .GT. 0 ) ALINE(JZ) = A0 ISPACE = 1 IF ( NODIST .EQ. 0 ) GO TO 120 C--> FIND DISTANCE BETWEEN TWO POINTS DIST = 0.0 DO 110 IS = 1,NSPACE 110 DIST = DIST + ( X(N,IS)-X(NLAST,IS) )**2 C MINIMUM DISTANCE IS ONE SPACE DIST = SQRT(DIST) IF ( K .NE. 1 ) THEN IF ( DMIN .GT. 0.0 ) THEN ISPACE = DIST/DMIN + 0.5 ELSE ISPACE = 1 ENDIF ENDIF IF ( ISPACE .GT. 10 ) ISPACE = 5 120 CONTINUE IF ( NODIST .GT. 0 .AND. K .GT. 1 ) THEN DO 130 I = 1,ISPACE 130 WRITE (NPRT,5030) SKIP 5030 FORMAT (17X, (101A1) ) ENDIF C LINEAR INTERPOLATION FOR COLUMN NUMBER JY = 1*(YMAX - DTEST )/RANGE 1 + (LINE+1)*(DTEST - YMIN)/RANGE + 0.1 C FLAG ZERO VALUE IF ( YMIN .LT. 0.0 .AND. YMAX .GT. 0.0 ) THEN JZ = 1*(YMAX - 0.0 )/RANGE 1 + (LINE+1)*(0.0 - YMIN)/RANGE + 0.1 ELSE JZ = 0 ENDIF c IF ( JY .GT. MID ) GO TO 150 c DO 140 I = JY,MID+1 c 140 ALINE(I) = AX c GO TO 170 c 150 DO 160 I = MID+1,JY c 160 ALINE(I) = AX c 170 CONTINUE DO 165 I = 1, JY 165 ALINE(I) = AX WRITE (NPRT,5040) N, D(INDEX), ALINE 5040 FORMAT (I4,2X,1PE10.3,1X,101A1) c IF ( JY .GT. MID ) GO TO 190 c DO 180 I = JY,MID+1 c 180 ALINE(I) = BLANK c GO TO 210 c 190 DO 200 I = MID+1,JY c 200 ALINE(I) = BLANK 210 CONTINUE DO 220 I = 2,LINE 220 ALINE(I) = DASH DO 230 I = 1,LINE+1,5 230 ALINE(I) = PLUS ALINE(MID+1) = DOT WRITE (NPRT,5020) ALINE RETURN END SUBROUTINE BC2UC (N, NSPACE, DLB, DLU) C * * * * * * * * * * * * * * * * * * * * * * * * * C CONVERT BARACENTRIC LOCAL DERIVATIVES TO C UNIT COORDINATE LOCAL DERIVATIVES C * * * * * * * * * * * * * * * * * * * * * * * * * DIMENSION DLU(NSPACE,N), DLB(NSPACE+1,N) C DLB = LOCAL DERIVATIVES IN BARACENTRIC COORDINATES C DLU = LOCAL DERIVATIVES IN UNIT COORDINATES C N = NUMBER OF NODES C NSPACE = DIMENSION OF UNIT SIMPLEX SPACE C LOOP OVER THE INTERPOLATION FUNCTIONS DO 20 K = 1, N DLBLST = DLB(NSPACE+1,K) C SUBTRACT OFF THE LAST BARACENTRIC VALUE DO 10 J = 1, NSPACE 10 DLU(J,K) = DLB(J,K) - DLBLST 20 CONTINUE RETURN END SUBROUTINE BELAST (IOPT, N, NSPACE, NG, GDH, H, 1 R, NS, B) C * * * * * * * * * * * * * * * * * * * * * * * * C ELASTICITY STRAIN-DISPLACEMENT RELATIONS (B) C * * * * * * * * * * * * * * * * * * * * * * * * cb DIMENSION GDH(NSPACE,N), B(NS,N*NG), H(N) DIMENSION GDH(NSPACE,N*NG), B(NS,N*NG), H(N*NG) C B = STRAIN-DISPLACEMENT MATRIX (RETURNED) C GDH = GLOBAL DERIVATIVES OF H C H = ELEMENT INTERPOLATION FUNCTIONS C IOPT = ELASTICITY CLASS C = 1, AXIAL BAR, NG = 1 C = 2, PLANE STRESS, NG = 2 C = 3, PLANE STRAIN, NG = 2 C = 4, AXISYMMETRIC, NG = 2, R = RADIUS C = 5, 3-D SOLID, NG = 3 C N = NUMBER OF NODES PER ELEMENT C NG = NUMBER OF PARAMETERS PER NODE C NS = NUMBER OF STRAINS (ROWS IN B) C NSPACE = DIMENSION OF SPACE IF ( IOPT.LT.1 .OR. IOPT.GT.5 ) STOP 'BELAST' DO 70 J = 1, N K = NG*(J - 1) + 1 L = K + 1 M = L + 1 C--> ONE-DIMENSIONAL AXIAL BAR, IOPT = 1 B(1,K) = GDH(1,J) IF ( IOPT .EQ. 1 ) GO TO 70 C-> PLANE STRESS, PLANE STRAIN, AXISYMMETRIC, 3D 20 B(2,K) = 0.0 B(3,K) = GDH(2,J) B(1,L) = 0.0 B(2,L) = GDH(2,J) B(3,L) = GDH(1,J) IF ( IOPT.EQ.2 .OR. IOPT.EQ.3 ) GO TO 70 C-> AXISYMMETRIC ONLY 30 IF ( IOPT .NE. 4 ) GO TO 40 IF ( R .LE. 0.0 ) STOP 'R=0, BELAST' B(4,K) = H(J)/R B(4,L) = 0.0 GO TO 70 C-> 3D SOLID ONLY 40 B(4,K) = 0.0 B(5,K) = 0.0 B(6,K) = GDH(3,J) B(4,L) = 0.0 B(5,L) = GDH(3,J) B(6,L) = 0.0 B(1,M) = 0.0 B(2,M) = 0.0 B(3,M) = 0.0 B(4,M) = GDH(3,J) B(5,M) = GDH(2,J) B(6,M) = GDH(1,J) 70 CONTINUE RETURN END SUBROUTINE BFLUX (FLUX, COORD, LBN, N, NSPACE, NFLUX, 1 NG, C, S, IOPT, NQP, NPARM, H, DGH, PT, WT, 2 XYZ, DLH, G, DLG, AJ, AJINV, LHOMO, ISEG, 3 NSEG, NBSFIX, NBSFLO, NBSPFX, FLTBS ) C * * * * * * * * * * * * * * * * * * * * * * * * * * C PROBLEM DEPENDENT BOUNDARY FLUX CONTRIBUTIONS C * * * * * * * * * * * * * * * * * * * * * * * * * * C ALWAYS USED DIMENSION COORD(LBN,NSPACE), FLUX(LBN,NG), C(NFLUX), 1 S(NFLUX,NFLUX) C OPTIONAL FOR NUMERICAL INTEGRATION cb DIMENSION H(N), DGH(NSPACE,N), PT(NPARM,0:NQP), cb 1 WT(0:NQP), XYZ(NSPACE), DLH(NSPACE,N), DIMENSION H(N*NG), DGH(NSPACE,N*NG), PT(NPARM,0:NQP), 1 WT(0:NQP), XYZ(NSPACE), DLH(NSPACE,N*NG), 2 G(LBN), DLG(NPARM,LBN), AJ(NSPACE,NSPACE), 3 AJINV(NSPACE,NSPACE) C OPTIONAL SEGMENT PROPERTIES DIMENSION FLTBS(0:NSEG,NBSFLO), NBSPFX(0:NSEG,NBSFIX) C C AJ = JACOBIAN C AJINV = JACOBIAN INVERSE C C = BOUNDARY FLUX COLUMN MATRIX CONTRIBUTIONS C COORD = SPATIAL COORDINATES OF SEGMENT NODES C DGH = GLOBAL DERIVATIVES INTERPOLATION FUNCTIONS C DLG = LOCAL DERIVATIVES GEOMETRIC INTERPOLATION C DLH = LOCAL DERIVATIVES INTERPOLATION FUNCTIONS C FLTBS = REAL PROPERTIES ON THE SEGMENTS C FLUX = SPECIFIED BOUNDARY FLUX COMPONENTS C G = GEOMETRIC INTERPOLATION FUNCTIONS C H = SOLUTION INTERPOLATION FUNCTIONS C IOPT = PROBLEM MATRIX REQUIREMENTS, MUST BE SET. C = 1, CALCULATE C ONLY C = 2, CALCULATE S ONLY C = 3, CALCULATE BOTH C AND S C ISEG = SEGMENT NUMBER C LBN = NO. OF NODES ON AN ELEMENT BOUNDARY SEGMENT C LHOMO = 1 IF SEGMENT PROPERTIES ARE HOMOGENEOUS C N = NUMBER OF SOLUTION NODES, N = LBN USUALLY C NBSFIX = NUMBER OF INTEGER PROPERTIES PER SEGMENT C NBSFLO = NUMBER OF REAL PROPERTIES PER SEGMENT C NBSPFX = INTEGER PROPERTIES ON THE SEGMENTS C NFLUX = N*NG = MAXIMUM NUMBER OF FLUX CONTRIBUTIONS C NG = NUMBER OF PARAMETERS PER NODE POINT C NPARM = PARAMETRIC GEOMETRY NODES, = NSPACE USUALLY C NQP = NUMBER OF QUADRATURE POINTS C NSEG = MAX NUMBER OF SEGMENTS C NSPACE = DIMENSION OF SOLUTION SPACE C PT = QUADRATURE COORDINATES C S = BOUNDARY FLUX SQUARE MATRIX C WT = QUADRATURE WEIGHTS C XYZ = SPACE COORDINATES AT A POINT c IOPT = 0 C .................................................... C ** BFLUX PROBLEM DEPENDENT STATEMENTS FOLLOW ** C .................................................... DIMENSION GPT(0:3), GWT(0:3) C T6 OR Q8 OR Q9, LBN = 3, NG = 1 write(6,*) fltbs call rprint (fltbs,nseg+1,nbsflo,0) IF ( LHOMO .EQ. 1) THEN THICK = FLTBS(1,1) ELSE THICK = FLTBS(ISEG,1) ENDIF THICK = 1.0 C GET GAUSS DATA (IN SPACE NPARM - 1) NQ = LBN NQ = MIN0 ( NQ, 3 ) CALL GAUSCO (NQ, GPT, GWT) c write(6,*) 'in bflux' c write(6,*) nparm, nqp c write(6,*) PT c call rprint(pt,nqp+1,nparm,0) c write(6,*) wT c CALL GAUSCO (NQ, PT(1,0), WT) c write(6,*) 'in bflux' c write(6,*) nparm, nqp c write(6,*) PT c call rprint(pt,nqp+1,nparm,0) c write(6,*) wT C ZERO WORKSPACE ARRAY CALL ZEROA (NBFREE,C) C COMPUTE NORMAL FLUX ARRAY BY NUMERICAL INTERGRATION DO 900 IQ = 1, NQ WIQ = GWT(IQ)*THICK PTIQ = GPT(IQ) c write(6,*) IQ, WIQ, ptiq, PT(nparm,IQ) C VARIABLE JACOBIAN ON CURVED LINE CALL DER3L (PTIQ, DLH) DXDR = DOT (LBN, DLH, COORD) DYDR = DOT (LBN, DLH, COORD(1,2)) IF ( DXDR .LT. 0.0 .OR. DYDR .LT. 0.0 ) 1 WRITE (6,*)'WARNING, DISTORTED SEGMENT', ISEG DLDR = SQRT (DXDR*DXDR + DYDR*DYDR) C GET SHAPE, INTERPOLATE NORMAL FLUX, 1---2---3 CALL SHP3L (PTIQ, H) FNORM = DOT (LBN, FLUX, H) C GIVEN HEAT FLUX INWARD DO 54 I =1, LBN 54 C(I) = C(I) + H(I)*WIQ*DLDR*FNORM 900 CONTINUE IOPT = 1 c write(6,*) thick,fnorm,c RETURN END SUBROUTINE BTDB (D, B, S, M, N, IOPT, COEFF) C * * * * * * * * * * * * * * * * * * * * * * C SPECIAL MATRIX MULTIPLICATION OPERATION C IF IOPT=0, S = (B)T*D*B*COEFF PRODUCT C IF IOPT=1, S = (B)T*D*B*COEFF + S NUM. INTG. C * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8 (A-H,O-Z) DIMENSION D(M,M), B(M,N), S(N,N) C D(M,M) = SYMMETRIC SQUARE MATRIX C B(M,N) = RECTANGLUAR ARRAY C S(N,N) = RETURNED SYMMETRIC SQ MATRIX C COEFF = SCALAR COEFFICIENT DO 40 L = 1,N DO 30 K = 1,N SUM = 0.0 DO 20 I = 1,M DBIK = 0.0 DO 10 J = 1,M C USE SYMMETRY OF D 10 DBIK = DBIK + D(J,I)*B(J,K) SUM = SUM + B(I,L)*DBIK 20 CONTINUE IF ( IOPT .EQ. 0 ) THEN S(L,K) = SUM*COEFF ELSE S(L,K) = S(L,K) + SUM*COEFF ENDIF 30 CONTINUE c 30 S(K,L) = S(L,K) 40 CONTINUE RETURN END SUBROUTINE BTDIAB (DIA, B, S, M, N, IOPT, COEFF) C * * * * * * * * * * * * * * * * * * * * * * * * * * C SPECIAL DIAGONIAL MATRIX MULTIPLICATION OPERATION C IF IOPT=0, S = (B)T*DIA*B*COEFF PRODUCT ONLY C IF IOPT=1, S = (B)T*DIA*B*COEFF + S NUM. INTEG. C * * * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8 (A-H,O-Z) DIMENSION DIA(M), B(M,N), S(N,N) C DIA(M) = DIAGONAL MATRIX C B(M,N) = RECTANGLUAR ARRAY C S(N,N) = RETURNED SYMMETRIC SQ MATRIX C COEFF = SCALAR COEFFICIENT DO 30 L = 1,N DO 20 K = 1,N SUM = 0.0 DO 10 I = 1,M 10 SUM = SUM + B(I,L)*DIA(I)*B(I,K) IF ( IOPT .EQ. 0 ) THEN S(L,K) = SUM*COEFF ELSE S(L,K) = S(L,K) + SUM*COEFF ENDIF 20 CONTINUE 30 CONTINUE RETURN END SUBROUTINE CALPRT (N, NNPFLO, H, PRTLPT, VALUES) C * * * * * * * * * * * * * * * * * * * * * * * * * * C CALCULATE NNPFLO PROPERTIES AT A LOCAL PT USING C ELEMENT'S NODAL PROPERTIES, PRTLPT, AND THE N C INTERPOLATION FUNCTIONS, H, AT THE POINT C * * * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8 (A-H,O-Z) DIMENSION H(N), PRTLPT(N,0:NNPFLO), VALUES(0:NNPFLO) C N = NUMBER OF NODES PER ELEMENT C NNPFLO = NO. OF FLOATING POINT NODAL PROPERTIES C H = C^0 INTERPOLATION FUNCTIONS FOR AN ELEMENT C PRTLPT = FLOATING PT PROPS OF ELEMENT'S NODES C VALUES = LOCAL VALUES OF PROPERTIES IF ( NNPFLO .LT. 1 ) STOP 'NNPFLO = 0, CALPRT' DO 20 I = 1, NNPFLO SUM = 0.0 DO 10 J = 1, N SUM = SUM + H(J)*PRTLPT(J,I) 10 CONTINUE VALUES(I) = SUM 20 CONTINUE RETURN END SUBROUTINE CCOUNT (M, NG, NRES, IBC, KODES, MAXACT, 1 NUMCE, MAXTYP, NREQ) C * * * * * * * * * * * * * * * * * * * * * * * * * * C CALCULATE NUMBER OF CONSTRAINT FLAGS OF EACH TYPE C * * * * * * * * * * * * * * * * * * * * * * * * * * PARAMETER ( NPRT = 6, NBUG = 6) DIMENSION IBC(M), NRES(MAXTYP), KODES(NG), 1 NREQ(MAXTYP) C M = TOTAL NUMBER OF SYSTEM NODES C NG = NO. OF PARAMETERS (DOF) PER NODE C IBC = NODAL POINT BOUNDARY RESTRAINT INDICATOR C KODES = LIST OF RESTRAINT INDICATORS AT A NODE C NRES = LIST OF NUMBER OF FLAGS OF EACH TYPE C = NUMBER OF CONSTR EQS ON EXIT, NREQ C MAXTYP = MAX NO OF DIFFERENT CONSTRAINT TYPES C MAXACT = ACTIVE NO OF TYPES C INITIALIZATION DO 10 I = 1, MAXTYP 10 NRES(I) = 0 DO 30 I = 1, M C DOES NODE I HAVE A NODAL PARAMETER CONSTRAINT ITEST = IABS( IBC(I) ) IF ( ITEST .GT. 0 ) THEN C EXTRACT PARAMETER CODES CALL PTCODE (I,NG,ITEST,KODES) DO 20 J = 1, NG K = KODES(J) C UPDATE CONSTRAINT COUNTERS IF ( K .GT. 0 ) NRES(K) = NRES(K) + 1 20 CONTINUE ENDIF 30 CONTINUE C CONVERT TO EQUATION COUNTERS NUMCE = 0 MAXACT = 1 WRITE (NPRT,5000) 5000 FORMAT ( /, 1 '*** NODAL PARAMETER CONSTRAINT LIST ***', /, 2 'TYPE EQUATIONS') DO 40 I = 1, MAXTYP K = NRES(I) IF ( K .GT. 0 ) MAXACT = I IF ( ((K/I)*I) .LT. K ) WRITE (NBUG,*) 1 'INVALID DATA FOR TYPE', I NREQ(I) = NRES(I)/I IF ( NREQ(I) .GT. 0 ) WRITE (NPRT,5020) I, NREQ(I) 5020 FORMAT ( I4, I10 ) 40 NUMCE = NUMCE + NREQ(I) RETURN END SUBROUTINE CEQBAN (JBW, NREQ, MAXACT, NUMCE, 1 NDXC, NDFREE) C * * * * * * * * * * * * * * * * * * * * * * * * C FIND MAXIMUM HALF BANDWIDTH REQUIRED BY C CONSTRAINT EQUATION MODIFICATION PROCEDURES C * * * * * * * * * * * * * * * * * * * * * * * * DIMENSION NDXC(MAXACT,NUMCE), NREQ(MAXACT) C JBW = MAX HALF BAND FROM CONSTRAINT EQUATIONS C MAXACT = NUMBER ACTIVE CONSTRAINT TYPES C NUMCE = TOTAL NUMBER CONSTRAINT EQS C NDXC(I,J) = CONSTR DOF NO I OF EQ J C NDFREE = TOTAL NO OF SYSTEM DEGREES OF FREEDOM JBW = 1 IEQ = NREQ(1) C--> LOOP OVER NON DIAGONAL CONSTRAINTS DO 30 IC = 2, MAXACT NTEST = NREQ(IC) IF ( NTEST .GT. 0 ) THEN C--> LOOP OVER TYPE IC EQUATIONS DO 20 J = 1, NTEST IEQ = IEQ + 1 IMIN = NDXC(1,IEQ) IMAX = IMIN C--> FIND EQUATION BANDWIDTH DO 10 I = 1, IC INDEX = NDXC(I,IEQ) IF ( INDEX .LT. IMIN ) IMIN = INDEX 10 IF ( INDEX .GT. IMAX ) IMAX = INDEX LBW = IMAX - IMIN + 1 C UPDATE MAXIMUM IF ( LBW .GT. JBW ) JBW = LBW 20 CONTINUE ENDIF 30 CONTINUE RETURN END SUBROUTINE CHANGE (NDFREE, DD, DDOLD, TOTAL, DIFF, 1 RATIO, IPRINT) C * * * * * * * * * * * * * * * * * * * * * * * * * * C CALCULATE THE MEAN CHANGE IN NODAL PARAMETERS FROM C THE LAST ITERATION C * * * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8 (A-H,O-Z) PARAMETER ( NPRT = 6 ) DIMENSION DD(NDFREE), DDOLD(NDFREE) C * CHANGE SHOULD BE CALLED BEFORE CORECT * C RATIO = DIFF/TOTAL C DIFF = SQRT(SUM OF (DD(I)-DDOLD(I))**2) C TOTAL = SQRT(SUM OF DDOLD(I)**2) C DDOLD = NODAL PARAMETER LIST FROM LAST ITERATION C DD = NODAL PARAMETERS FROM CURRENT ITERATION C NDFREE = TOTAL NO OF DEGREES OF FREEDOM IN SYS C IPRINT > 0, PRINT DIFF, TOTAL, AND RATIO CDP SQRT(Z) = DSQRT(Z) DIFF = 0.0 TOTAL = 0.1E-10 DO 10 I = 1, NDFREE TOTAL = TOTAL + DDOLD(I)*DDOLD(I) 10 DIFF = DIFF + (DD(I)-DDOLD(I))**2 TOTAL = SQRT(TOTAL) DIFF = SQRT(DIFF) RATIO = DIFF/TOTAL IF ( IPRINT .EQ. 0 ) RETURN WRITE (NPRT,5000) DIFF, TOTAL, RATIO 5000 FORMAT ( 1 '*** NODAL DOF FOR CURRENT AND PREVIOUS ITERATIONS ***',/, 2 'ROOT MEAN SQ OF DIFFERENCES . . . . . ',1PE13.5,/, 3 'ROOT MEAN SQ OF PREVIOUS VALUES . . . ',1PE13.5,/, 4 'RATIO OF ABOVE QUANTITIES . . . . . . ',1PE13.5) RETURN END SUBROUTINE CHKSHP (N, NSPACE, LSHAPE, LBN) C * * * * * * * * * * * * * * * * * * * * * * * * * * * C CHECK LSHAPE DATA FOR FREQUENT USER ERRORS C * * * * * * * * * * * * * * * * * * * * * * * * * * * PARAMETER (NPRT = 6 ) C FORCE THE INPUT VALUE IF NEGATIVE IF ( LSHAPE .LT. 0 ) THEN LSHAPE = IABS( LSHAPE ) RETURN ENDIF C LINE IF ( N .EQ. 2 .AND. LSHAPE .NE. 1) THEN LSHAPE = 1 WRITE(NPRT,1000) LSHAPE 1000 FORMAT ('********************************',/, 1 '* WARNING LSHAPE CHANGED TO', I2, ' *', /, 2 '********************************') ENDIF C TRIANGLE IF ( NSPACE .GT. 1 .AND. N .EQ. 3 .AND. LSHAPE .NE. 2) THEN LSHAPE = 2 WRITE(NPRT,1000) LSHAPE ENDIF C QUADRILATERAL IF ( NSPACE .GT. 1 .AND. N .EQ. 4 .AND. LSHAPE .NE. 3) THEN LSHAPE = 3 WRITE(NPRT,1000) LSHAPE ENDIF C TRI OR WEDGE IF ( N .EQ. 6 .AND. LSHAPE .NE. 2) THEN IF ( NSPACE .EQ. 2 ) THEN LSHAPE = 2 WRITE(NPRT,1000) LSHAPE ENDIF ENDIF C QUAD OR HEX IF ( N .EQ. 8 .AND. LSHAPE .NE. 3) THEN IF ( NSPACE .EQ. 3 ) THEN LSHAPE = 3 WRITE(NPRT,1000) LSHAPE ENDIF ENDIF RETURN END SUBROUTINE CONDSE (NTOTAL, NELFRE, S, C) C * * * * * * * * * * * * * * * * * * * * * * * C CONDENSATION OF ELEMENT MATRICES TO REMOVE C INTERNAL DEGREES OF FREEDOM C * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8(A-H,O-Z) PARAMETER ( ZERO = 0.0 ) DIMENSION S(NTOTAL,NTOTAL), C(NTOTAL) C INTERNAL DEGREES OF FREEDOM *MUST* COME LAST C : SAA : SAB : : DA : : CA : C :......:......: :....: = :....: C : SBA : SBB : : DB : : CB : C ENTER FULL S ; RETURN CONDENSED IN SAA AND CA C DIMENSION SAA(NELFRE,NELFRE), CA(NELFRE) C SAA* = (SAA) - (SAB)*(SBB)I*(SAB)T C CA* = (CA) - (SAB)*(SBB)I*(CB) C NTOTAL = ORIG. NO. OF D.O.F. OF ELEMENT C NELFRE = FINAL NO. OF D.O.F. OF ELEMENT C NELIM = NUMBER OF DOF TO ELIMINATE C S = SQUARE ELEMENT MATRIX C C = ELEMENT COLUMN MATRIX NELIM = NTOTAL - NELFRE DO 30 I = 1, NELIM J = NTOTAL - I K = J + 1 SKK = S(K,K) CK = C(K) IF ( SKK .NE. ZERO ) THEN C(K) = CK/SKK DO 20 L = 1, J SLKSKK = S(L,K)/SKK S(L,K) = SLKSKK DO 10 M = L, J S(L,M) = S(L,M) - S(K,M)*SLKSKK 10 S(M,L) = S(L,M) C(L) = C(L) - CK*SLKSKK 20 CONTINUE ENDIF 30 CONTINUE RETURN END SUBROUTINE CONTROL (TITLE, M, NE, NG, N, NSPACE, NSEG, LBN, 1 NITER, NCURVE, INRHS, ISAY, NNPFIX, NNPFLO, NLPFIX, 2 NLPFLO, MISCFX, MISCFL, NHOMO, LHOMO, NPTWRT, LEMWRT, 3 NTAPE1, NTAPE2, NTAPE3, NTAPE4, NTAPE5, NULCOL, 4 NDFREE, NELFRE, NFLUX, IPTEST, LPTEST, NRB, NQP, 5 LSHAPE, NLTYPE, MODE, IBUG, NBSFIX, NBSFLO, NGF) C 1 2 3 4 5 6 712 C23456789012345678901234567890123456789012345678901234567890-----------X cb DIMENSION TITLE(15) CHARACTER*4 TITLE(15) C PRINT AUTHOR CREDITS C CALL TOOT C--> ** READ AND PRINT TITLE AND CONTROL DATA ** NTAPE3 = 0 NTAPE4 = 0 NTAPE5 = 0 READ (5,1234) TITLE WRITE (6,1234) TITLE 1234 FORMAT ( 15A4 ) READ (5,5020) M, NE, NG, N, 1 NSPACE, NSEG, LBN, NITER, 2 NCURVE, INRHS, ISAY, NRB, 3 NQP, LSHAPE, NLTYPE, MODE 5020 FORMAT ( 16I5 ) C CHECK FOR EXTRA OUTPUT REQUESTS IBUG = 0 IF ( NITER .LT. 0 ) THEN IBUG = 1 NITER = IABS ( NITER ) ENDIF IF ( LSHAPE .LT. 1 ) LSHAPE = 1 IF ( N .LT. 1 ) N = 2 IF ( NG .LT. 1 ) NG = 1 IF ( NITER .LT. 1 ) NITER = 1 IF ( NLTYPE .LT. 1 ) NLTYPE = 1 IF ( NRB .LT. 1 ) NRB = 1 IF ( NSPACE .LT. 1 ) NSPACE = 1 C CHECK ELEMENT SHAPE DATA CALL CHKSHP (N, NSPACE, LSHAPE, LBN) MODE = 1 IF ( NITER .LT. 1 ) NITER = 1 WRITE (6,5030) M, NE, NG, N, NSPACE, NSEG, LBN, 1 NITER, NCURVE, INRHS, ISAY, NRB, NQP, 2 LSHAPE, NLTYPE, MODE 5030 FORMAT (/,'**** PROBLEM PARAMETERS (DEFAULT) ****',/, 1 'NUMBER OF NODAL POINTS IN SYSTEM ............',I5,/, 2 'NUMBER OF ELEMENTS IN SYSTEM ................',I5,/, 4 'NUMBER OF PARAMETERS PER NODE (1)............',I5,/, 3 'NUMBER OF NODES PER ELEMENT (2)..............',I5,/, 5 'DIMENSION OF SPACE (1).......................',I5,/, 6 'NUMBER OF BOUNDARIES WITH GIVEN FLUX ........',I5,/, 7 'NUMBER OF NODES ON BOUNDARY SEGMENT .........',I5,/, 8 'NUMBER OF ITERATIONS TO BE RUN (1)...........',I5,/, 9 'NUMBER OF CONTOURS BETWEEN 5 & 95% ..........',I5,/, + 'INITIAL FORCING VECTOR (0-OMIT, 1-READ)......',I5,/, 1 'NUMBER OF USER REMARKS LINES ................',I5,/, 2 'NUMBER OF ROWS IN B MATRIX (1)...............',I5,/, 3 'NUMBER OF QUADRATURE POINTS .................',I5,/, 4 'SHAPE 1-LINE 2-TRI 3-QUAD 4-HEX 5-TET (1)....',I5,/, 5 'NUMBER OF DIFFERENT ELEMENT TYPES (1)........',I5,/, 6 'STIFFNESS STORAGE MODE: (0-SKY, 1-BAND)......',I5) READ (5,5070) NNPFIX, NNPFLO, NLPFIX, NLPFLO, 1 MISCFX, MISCFL, NHOMO, LHOMO, 2 NPTWRT, LEMWRT, NTAPE1, NTAPE2, 3 NGF, NULCOL, NBSFIX, NBSFLO 5070 FORMAT ( 16I5 ) IF ( NSEG .GT. 0 .AND. NGF .LT. 1 ) THEN WRITE (6,*) 'WARNING, NGF < 1, SET TO NGF = NG' NGF = NG ENDIF WRITE (6,5080) NGF, NNPFIX, NNPFLO, NLPFIX, NLPFLO, 1 NBSFIX, NBSFLO, MISCFX, MISCFL 5080 FORMAT ( 8 'NUMBER OF FLUX COMPONENTS PER NODE (NG)......',I5,/, 1 'NUMBER OF INTEGER PROPERTIES PER NODE .......',I5,/, 2 'NUMBER OF REAL PROPERTIES PER NODE ..........',I5,/, 3 'NUMBER OF INTEGER PROPERTIES PER ELEMENT ....',I5,/, 4 'NUMBER OF REAL PROPERTIES PER ELEMENT .......',I5,/, 3 'NUMBER OF INTEGER PROPERTIES PER SEGMENT ....',I5,/, 4 'NUMBER OF REAL PROPERTIES PER SEGMENT .......',I5,/, 5 'NUMBER OF INTEGER MISCELLANEOUS PROPERTIES .',I5,/, 6 'NUMBER OF REAL MISCELLANEOUS PROPERTIES ....',I5) IF ( LBN .GT. N ) 1 STOP 'INCONSISTANT VALUES OF LBN AND N.' NELFRE = N*NG NDFREE = M*NG NFLUX = LBN*NG WRITE (6,5081) NELFRE, NFLUX, NDFREE 5081 FORMAT ( 1 'NUMBER OF D.O.F. FOR ELEMENT ................',I5,/, 2 'NUMBER OF D.O.F. ON FLUX SEGMENT ............',I5,/, 3 'NUMBER OF D.O.F. IN TOTAL SYSTEM ............',I5) IF ( NHOMO .EQ. 1 ) WRITE (6,*) 1 'NODAL POINT PROPERTIES ARE HOMOGENEOUS.' IF ( LHOMO .EQ. 1 ) WRITE (6,*) 1 'ELEMENT PROPERTIES ARE HOMOGENEOUS.' NSUM = NTAPE1 + NTAPE2 + NTAPE3 + NTAPE4 + NTAPE5 IF ( NSUM .GT. 0 ) WRITE (6,5180) 1 NTAPE1, NTAPE2, NTAPE3, NTAPE4, NTAPE5 5180 FORMAT ( /, 'OPTIONAL UNIT NUMBERS (UTILIZED IF > 0)',/, 1 'NTAPE1 = ',I2,', NTAPE2 = ',I2,/,'NTAPE3 = ',I2, 2 ', NTAPE4 = ',I2,', NTAPE5 = ',I2) IF ( NPTWRT .EQ. 0 ) WRITE (6,*) 1 'NODAL PARAMETERS TO BE LISTED BY NODES' IF ( LEMWRT .EQ. 0 ) WRITE (6,*) 1 'NODAL PARAMETERS TO BE LISTED BY ELEMENTS' IF ( NULCOL .NE. 0 ) WRITE (6,*) 1 'ALL ELEMENT COLUMN MATRICES ARE ZERO.' cb IF ( NTAPE1 .GT. 0 ) REWIND NTAPE1 cb IF ( NTAPE2 .GT. 0 ) REWIND NTAPE2 cb IF ( NTAPE3 .GT. 0 ) REWIND NTAPE3 cb IF ( NTAPE4 .GT. 0 ) REWIND NTAPE4 cb IF ( NTAPE5 .GT. 0 ) REWIND NTAPE5 IF ( ISAY .GT. 0 ) CALL IREMRK (ISAY) C SET INITIAL CONSTANTS C LPTEST > 0, ELEMENT PROPERTIES ARE DEFINED C IPTEST > 0, SOME PROPERTIES ARE DEFINED C NBSFIX = NUMBER OF FIXED PT SEGMENT PROP C NBSFLO = NUMBER OF FLOATING PT SEGMENT PROP C NLPFIX = NUMBER OF FIXED PT ELEMENT PROP C NLPFLO = NUMBER OF FLOATING PT ELEMENT PROP C NNPFIX = NUMBER OF FIXED PT NUMBER PROP C NNPFLO = NUMBER OF FLOATING PT NUMBER PROP C MISCFL = NUMBER OF MISC FLOATING PT SYSTEM PROP C MISCFX = NUMBER OF MISC FIXED PT SYSTEM PROP C MAXTYP = MAX ALLOWED CONSTRAINT TYPE C RATIO = CONSTANT FOR ITER CONTROL, SEE MODEL RATIO = 1.0 C MAXTYP = 5 C IF ( NFLUX .LT. 1 ) NFLUX = 1 IPTEST = NNPFIX + NNPFLO + NLPFIX + NLPFLO 1 + NBSFIX + NBSFLO + MISCFX + MISCFL LPTEST = NLPFIX + NLPFLO RETURN END SUBROUTINE CORECT (NDFREE, DD, DDOLD) C * * * * * * * * * * * * * * * * * * * * * * * * * * C CALCULATE NEW STARTING VALUES FOR NEXT ITERATION C * * * * * * * * * * * * * * * * * * * * * * * * * * C OVER RELAXATION METHOD CDP IMPLICIT REAL*8(A-H,O-Z) DIMENSION DD(NDFREE), DDOLD(NDFREE) PARAMETER ( OMEGA = 1.25 ) C DD = CALCULATED DOF FROM LAST ITERATION C DDOLD = DOF TO BE USED TO START NEXT ITERATION C NDFREE = TOTAL NO OF SYS DEGREES OF FREEDOM DO 10 I = 1,NDFREE 10 DDOLD(I) = DDOLD(I) + OMEGA*(DD(I)-DDOLD(I)) RETURN END SUBROUTINE DCHECK (DELTA,N,NSPACE) C * * * * * * * * * * * * * * * * * * * * * * * * * * C CHECKING OF THE LOCAL COORDINATE DERIVATIVES OF THE C N SHAPE FUNCTIONS AT A LOCAL POINT FOR A C0 ELEMENT C * * * * * * * * * * * * * * * * * * * * * * * * * * DOUBLE PRECISION ONE, SUM, TOL PARAMETER ( ONE = 1.0D0, TOL = 1.0D-7, NPRT = 6 ) DIMENSION DELTA(NSPACE,N) C DELTA = LOCAL DERIVATIVES OF SHAPE FUNCTIONS C N = NUMBER OF SHAPE FUNCTIONS C NSPACE = DIMENSION OF LOCAL SPACE IERR = 0 DO 20 J = 1,NSPACE SUM = 0.D0 DO 10 I = 1,N 10 SUM = SUM + DELTA(J,I) IF ( ABS(SUM) .GT. TOL ) THEN IF ( IERR .EQ. 0 ) WRITE (NPRT,*) & 'SUPPLIED DERIVATIVES ARE INCORRECT' IERR = 1 WRITE (NPRT,*) 'J, SUM', J, SUM ENDIF 20 CONTINUE IF ( IERR .NE. 0 ) THEN CALL RPRINT (DELTA,N,NSPACE,1) WRITE (NPRT,*) 'END OF WARNING FROM DCHECK' ENDIF RETURN END SUBROUTINE DEGPAR (IPT, JPARM, NG, INDEX) C * * * * * * * * * * * * * * * * * * * * * * * C DETERMINE THE DEGREE OF FREEDOM NUMBER C OF NODAL PARAMETER JPARM AT NODE POINT IPT C * * * * * * * * * * * * * * * * * * * * * * * C NG = NUMBER OF PARAMETERS PER NODE INDEX = NG*(IPT-1) + JPARM RETURN END SUBROUTINE DELAST (IOPT, E, PR, T, D, NS) C * * * * * * * * * * * * * * * * * * * * * * * C CONSTITUTIVE MATRIX, ELASTICITY (D) C * * * * * * * * * * * * * * * * * * * * * * * DIMENSION D(NS,NS) C D = CONSTITUTIVE MATRIX C E = MODULUS OF ELASTICITY C IOPT = ELASTICITY CLASS C = 1, AXIAL BAR, T = AREA C = 2, PLANE STRESS, T = THICKNESS C = 3, PLANE STRAIN, T = THICKNESS C = 4, AXISYMMETRIC C = 5, 3-D SOLID C NS = NUMBER OF STRAINS (ROWS IN B-MATRIX) C PR = POISSON'S RATIO C T = AREA, OR THICKNESS IF ( T.LE.0.0 ) T = 1.0 IF ( IOPT.LT.1 .OR. IOPT.GT.5 ) STOP 'DELAST' IF ( IOPT.NE.1 ) GO TO 20 C 1-D, SXX D(1,1) = E*T RETURN 20 IF ( IOPT.NE.2 ) GO TO 30 C PLANE STRESS ONLY, SXX, SYY, SXY C = T*E/(1.-PR*PR) D(1,1) = C D(2,1) = C*PR D(3,1) = 0.0 D(1,2) = C*PR D(2,2) = C D(3,2) = 0.0 D(1,3) = 0.0 D(2,3) = 0.0 D(3,3) = 0.5*T*E/(1.+PR) RETURN 30 CONTINUE C PLANE STRAIN OR 3-D, SXX, SYY, SXY C = E*(1.-PR)/(1.+PR)/(1.-PR-PR) C2 = C*PR/(1.-PR) G = 0.5*E/(1.+PR) D(1,1) = C D(2,1) = C2 D(3,1) = 0.0 D(1,2) = C2 D(2,2) = C D(3,2) = 0.0 D(1,3) = 0.0 D(2,3) = 0.0 D(3,3) = G IF ( IOPT.EQ.3 ) RETURN C AXISYMMETRIC ONLY, SXX, SYY, SXY, STT D(4,1) = C2 D(4,2) = C2 D(4,3) = 0.0 D(1,4) = C2 D(2,4) = C2 D(3,4) = 0.0 D(4,4) = C IF ( IOPT.NE.5 ) RETURN C 3-D SOLID ONLY, SXX, SYY, SXY, SZZ, SXZ, SYZ D(5,1) = 0.0 D(6,1) = 0.0 D(5,2) = 0.0 D(6,2) = 0.0 D(5,3) = 0.0 D(6,3) = 0.0 D(5,4) = 0.0 D(6,4) = 0.0 D(1,5) = 0.0 D(2,5) = 0.0 D(3,5) = 0.0 D(4,5) = 0.0 D(5,5) = G D(6,5) = 0.0 D(1,6) = 0.0 D(2,6) = 0.0 D(3,6) = 0.0 D(4,6) = 0.0 D(5,6) = 0.0 D(6,6) = G RETURN END SUBROUTINE DER16QS (R,S,DH) C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C LOCAL DERIVATIVES FOR A SERENDIPITY 16 NODE QUAD C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * PARAMETER ( PT667 = 0.66666666666667 ,PT1D12 = 0.083333333333333 1 ,HALF = 0.5) C SEE SHP16QS FOR NODE LOCATIONS DIMENSION DH(2,16) RR = R*R SS = S*S RRR = R*R*R SSS = S*S*S RP = 1. + R RM = 1. - R R1 = R - 1. SP = 1. + S SM = 1. - S DH(1,1) = PT1D12*SM*(16.*RRR - 12.*RR - 2.*R + 4.*SSS - S + 4.) DH(1,2) = PT1D12*SM*(16.*RRR + 12.*RR - 2.*R - 4.*SSS + S - 4.) DH(1,3) = PT1D12*SP*(16.*RRR + 12.*RR - 2.*R + 4.*SSS - S - 4.) DH(1,4) = PT1D12*SP*(16.*RRR - 12.*RR - 2.*R - 4.*SSS + S + 4.) DH(1,5) = PT667*(4.*R - 1. + 3.*RR - 8.*RRR)*SM DH(1,6) = PT667*S*SM*SP*( -1. + 2.*S) DH(1,7) = PT667*(1. + 4.*R - 3.*RR - 8.*RRR)*SP DH(1,8) = -PT667*S*SM*SP*(1. + 2.*S) DH(1,9) = R*(-5. + 8.*RR)*SM DH(1,10) = HALF*SM*SP*(1. - 2.*S)*(1. + 2.*S) DH(1,11) = R*( -5. + 8.*RR)*SP DH(1,12) = HALF*SM*SP*( -1. + 2.*S)*(1. + 2.*S) DH(1,13) = PT667*(1. + 4.*R - 3.*RR - 8.*RRR)*SM DH(1,14) = PT667*S*SM*SP*(1. + 2.*S) DH(1,15) = PT667*(4.*R - 1. + 3.*RR - 8.*RRR)*SP DH(1,16) = PT667*S*SM*SP*(1. - 2.*S) DH(2,1) = PT1D12*RM*(16.*SSS - 12.*SS - 2.*S + 4.*RRR - R + 4.) DH(2,2) = PT1D12*RP*(16.*SSS - 12.*SS - 2.*S - 4.*RRR + R + 4.) DH(2,3) = PT1D12*RP*(16.*SSS + 12.*SS - 2.*S + 4.*RRR - R - 4.) DH(2,4) = PT1D12*R1*(-16.*SSS - 12.*SS + 2.*S + 4.*RRR - R + 4.) DH(2,5) = PT667*R*R1*RP*(2.*R - 1.) DH(2,6) = PT667*( -1. + 4.*S + 3.*SS - 8.*SSS)*RP DH(2,7) = PT667*R*RM*RP*(1. + 2.*R) DH(2,8) = PT667*( -1. - 4.*S + 3.*SS + 8.*SSS)*R1 DH(2,9) = HALF*RM*RP*(2.*R - 1.)*(1. + 2.*R) DH(2,10) = S*( -5. + 8.*SS)*RP DH(2,11) = HALF*R1*RP*(2.*R - 1.)*(1. + 2.*R) DH(2,12) = S*(5. - 8.*SS)*R1 DH(2,13) = PT667*R*R1*RP*(1. + 2.*R) DH(2,14) = PT667*(1. + 4.*S - 3.*SS - 8.*SSS)*RP DH(2,15) = PT667*R*RM*RP*(2.*R - 1.) DH(2,16) = PT667*(1. - 4.*S - 3.*SS + 8.*SSS)*R1 RETURN END SUBROUTINE DER16R (R,S,A,B,DH) C * * * * * * * * * * * * * * * * * * * * * * * * * C WARNING, this code is not fully checked. No known bugs. C FIRST DERIVATIVES OF A C C1 RECTANGULAR ELEMENT IN UNIT COORDINATES C USING TENSOR PRODUCTS OF 1D BASIS C * * * * * * * * * * * * * * * * * * * * * * * * * DIMENSION DH(2,16), HR(4), DHR(4), HS(4), DHS(4) C DOF ARE W W,X W,Y W,XY AT EACH NODE (NG=4) C X // R, Y // S. S C A = PHYSICAL LENGTH IN X 4 -------- 3 C B = PHYSICAL LENGTH IN Y I I C R,S = LOCAL UNIT COORDS I I C 1@(0,0), 3@(1,1) 1 -------- 2 ->R C C Evaluate the 1D interpolations CALL SHPC1L (R,A,HR) CALL SHPC1L (S,B,HS) CALL DERC1L (R,A,DHR) CALL DERC1L (S,B,DHS) C Form tensor products for R direction DH(1,1) = DHR(1)*HS(1) DH(1,2) = DHR(2)*HS(1) DH(1,3) = DHR(1)*HS(2) DH(1,4) = DHR(2)*HS(2) DH(1,5) = DHR(3)*HS(1) DH(1,6) = DHR(4)*HS(1) DH(1,7) = DHR(3)*HS(2) DH(1,8) = DHR(4)*HS(2) DH(1,9) = DHR(3)*HS(3) DH(1,10) = DHR(4)*HS(3) DH(1,11) = DHR(3)*HS(4) DH(1,12) = DHR(4)*HS(4) DH(1,13) = DHR(1)*HS(3) DH(1,14) = DHR(2)*HS(3) DH(1,15) = DHR(1)*HS(4) DH(1,16) = DHR(2)*HS(4) C Form tensor products for S direction DH(2,1) = HR(1)*DHS(1) DH(2,2) = HR(2)*DHS(1) DH(2,3) = HR(1)*DHS(2) DH(2,4) = HR(2)*DHS(2) DH(2,5) = HR(3)*DHS(1) DH(2,6) = HR(4)*DHS(1) DH(2,7) = HR(3)*DHS(2) DH(2,8) = HR(4)*DHS(2) DH(2,9) = HR(3)*DHS(3) DH(2,10) = HR(4)*DHS(3) DH(2,11) = HR(3)*DHS(4) DH(2,12) = HR(4)*DHS(4) DH(2,13) = HR(1)*DHS(3) DH(2,14) = HR(2)*DHS(3) DH(2,15) = HR(1)*DHS(4) DH(2,16) = HR(2)*DHS(4) RETURN END SUBROUTINE DER17Q (R,S,DH) C ****************************************************************** C LOCAL DERIVATIVES OF SERENDIPITY QUAD WITH 17 NODES C ****************************************************************** PARAMETER ( PT667 = 0.66666666666667 ,PT1D12 = 0.083333333333333 1 ,HALF = 0.5) C SEE SHP17Q FOR NODE LOCATIONS DIMENSION DH(2,17) RP = 1. + R RM = 1. - R SP = 1. + S SM = 1. - S R1 = R - 1. RR = R*R SS = S*S RRR = R*R*R SSS = S*S*S DH(1,1) = PT1D12*SM*(16.*RRR-12.*RR-6.*R*S-8.*R+4.*SSS-S+4.) DH(1,2) = PT1D12*SM*(16.*RRR+12.*RR-6.*R*S-8.*R-4.*SSS+S-4.) DH(1,3) = PT1D12*SP*(16.*RRR+12.*RR+6.*R*S-8.*R+4.*SSS-S-4.) DH(1,4) = PT1D12*SP*(16.*RRR-12.*RR+6.*R*S-8.*R-4.*SSS+S+4.) DH(1,5) = -PT667*(1. - 4.*R - 3.*RR + 8.*RRR)*SM DH(1,6) = PT667*S*SM*SP*( -1. + 2.*S) DH(1,7) = -PT667*(-1. - 4.*R + 3.*RR + 8.*RRR)*SP DH(1,8) = -PT667*S*SM*SP*(1. + 2.*S) DH(1,9) = R*SM*(8.*RR + S - 4.) DH(1,10) = HALF*SM*SP*(2.*R - 4.*SS + 1.) DH(1,11) = R*SP*(8.*RR - S - 4.) DH(1,12) = HALF*SM*SP*(2.*R - 1. + 4.*SS) DH(1,13) = PT667*(1. + 4.*R - 3.*RR - 8.*RRR)*SM DH(1,14) = PT667*S*SM*SP*(1. + 2.*S) DH(1,15) = -PT667*(1. - 4.*R - 3.*RR + 8.*RRR)*SP DH(1,16) = PT667*S*SM*SP*(1. - 2.*S) DH(1,17) = -2.*R*SM*SP DH(2,1) = PT1D12*RM*(16.*SSS-12.*SS-6.*R*S-8.*S+4.*RRR-R+4.) DH(2,2) = -PT1D12*RP*(-16.*SSS+12.*SS-6.*R*S+8.*S+4.*RRR-R-4.) DH(2,3) = PT1D12*RP*(16.*SSS+12.*SS+6.*R*S-8.*S+4.*RRR-R-4.) DH(2,4) = PT1D12*R1*(-16.*SSS-12.*SS+6.*R*S+8.*S+4.*RRR-R+4.) DH(2,5) = PT667*R*R1*RP*(2.*R - 1.) DH(2,6) = -PT667*(1. - 4.*S - 3.*SS + 8.*SSS)*RP DH(2,7) = -PT667*R*R1*RP*(1. + 2.*R) DH(2,8) = PT667*(-1. - 4.*S + 3.*SS + 8.*SSS)*R1 DH(2,9) = -HALF*R1*RP*(2.*S - 1. + 4.*RR) DH(2,10) = -S*RP*(-8.*SS + R + 4.) DH(2,11) = HALF*R1*RP*( -2.*S + 4.*RR - 1.) DH(2,12) = -S*R1*(8.*SS + R - 4.) DH(2,13) = PT667*R*R1*RP*(1. + 2.*R) DH(2,14) = -PT667*( -1. - 4.*S + 3.*SS + 8.*SSS)*RP DH(2,15) = -PT667*R*R1*RP*(2.*R - 1.) DH(2,16) = PT667*(1. - 4.*S - 3.*SS + 8.*SSS)*R1 DH(2,17) = 2.*S*R1*RP RETURN END SUBROUTINE DER208 (R, S, T, DH, LNODE) C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C LOCAL DERIVATIVES OF INTERPOLATION FUNCTIONS FOR AN C 8 TO 20 NODE HEXAHEDRON, SEE SHP208 FOR TOPOLOGY FIGURE C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * CIBM IMPLICIT REAL*8 (A-H,O-Z) DIMENSION DH(3,20), LNODE(20), I1(20), I2(20) DATA I1 /8*0, 1, 2, 3, 4, 5, 6, 7, 8, 1, 2, 3, 4/ DATA I2 /8*0, 2, 3, 4, 1, 6, 7, 8, 5, 5, 6, 7, 8/ DATA FP, FM / 0.5, -0.5 / C FOR PARAMETER DEFINITIONS SEE SUBROUTINE SHP208 C R,S,T = LOCAL COORDINATES OF THE POINT -1 LE (R,S,T) LE +1 C DH = LOCAL DERIVATIVES OF SHAPE FUNCTIONS, 0 IF LNODE(I) = 0 C LNODE = ARRAY OF ELEMENT INCIDENCES, C IF LNODE(I)=0 THEN LOCAL NODE I IS NOT CONSIDERED IN ANALYSIS C I1, I2 = CORNER NODES OF TWELVE EDGES RP = 0.5*(1. + R) SP = 0.5*(1. + S) TP = 0.5*(1. + T) RM = 0.5*(1. - R) SM = 0.5*(1. - S) TM = 0.5*(1. - T) RZ = 1. - R*R SZ = 1. - S*S TZ = 1. - T*T FR = -2.0*R FS = -2.0*S FT = -2.0*T C DERIVATIVES OF TRI-LINEAR CORNERS DH(1,1 ) = TP*SP*FP DH(2,1 ) = TP*FP*RP DH(3,1 ) = FP*SP*RP DH(1,2 ) = TP*SP*FM DH(2,2 ) = TP*FP*RM DH(3,2 ) = FP*SP*RM DH(1,3 ) = TP*SM*FM DH(2,3 ) = TP*FM*RM DH(3,3 ) = FP*SM*RM DH(1,4 ) = TP*SM*FP DH(2,4 ) = TP*FM*RP DH(3,4 ) = FP*SM*RP DH(1,5 ) = TM*SP*FP DH(2,5 ) = TM*FP*RP DH(3,5 ) = FM*SP*RP DH(1,6 ) = TM*SP*FM DH(2,6 ) = TM*FP*RM DH(3,6 ) = FM*SP*RM DH(1,7 ) = TM*SM*FM DH(2,7 ) = TM*FM*RM DH(3,7 ) = FM*SM*RM DH(1,8 ) = TM*SM*FP DH(2,8 ) = TM*FM*RP DH(3,8 ) = FM*SM*RP C DERIVATIVES OF EDGE BUBBLES DH(1,9 ) = TP*SP*FR*0.5 DH(2,9 ) = TP*FP*RZ*0.5 DH(3,9 ) = FP*SP*RZ*0.5 DH(1,10) = TP*SZ*FM*0.5 DH(2,10) = TP*FS*RM*0.5 DH(3,10) = FP*SZ*RM*0.5 DH(1,11) = TP*SM*FR*0.5 DH(2,11) = TP*FM*RZ*0.5 DH(3,11) = FP*SM*RZ*0.5 DH(1,12) = TP*SZ*FP*0.5 DH(2,12) = TP*FS*RP*0.5 DH(3,12) = FP*SZ*RP*0.5 DH(1,13) = TM*SP*FR*0.5 DH(2,13) = TM*FP*RZ*0.5 DH(3,13) = FM*SP*RZ*0.5 DH(1,14) = TM*SZ*FM*0.5 DH(2,14) = TM*FS*RM*0.5 DH(3,14) = FM*SZ*RM*0.5 DH(1,15) = TM*SM*FR*0.5 DH(2,15) = TM*FM*RZ*0.5 DH(3,15) = FM*SM*RZ*0.5 DH(1,16) = TM*SZ*FP*0.5 DH(2,16) = TM*FS*RP*0.5 DH(3,16) = FM*SZ*RP*0.5 DH(1,17) = TZ*SP*FP*0.5 DH(2,17) = TZ*FP*RP*0.5 DH(3,17) = FT*SP*RP*0.5 DH(1,18) = TZ*SP*FM*0.5 DH(2,18) = TZ*FP*RM*0.5 DH(3,18) = FT*SP*RM*0.5 DH(1,19) = TZ*SM*FM*0.5 DH(2,19) = TZ*FM*RM*0.5 DH(3,19) = FT*SM*RM*0.5 DH(1,20) = TZ*SM*FP*0.5 DH(2,20) = TZ*FM*RP*0.5 DH(3,20) = FT*SM*RP*0.5 C LOOP OVER TWELVE EDGES DO 20 K = 9,20 IF ( LNODE(K) .EQ. 0 ) THEN C ZERO EDGE BUBBLE DERIVATIVES DH(1,K) = 0.0 DH(2,K) = 0.0 DH(3,K) = 0.0 ELSE C ENRICH DERIVATIVES AT TWO ENDS OF EDGE DH1 = DH(1,K) DH2 = DH(2,K) DH3 = DH(3,K) K1 = I1(K) K2 = I2(K) DH(1,K1) = DH(1,K1) - DH1 DH(2,K1) = DH(2,K1) - DH2 DH(3,K1) = DH(3,K1) - DH3 DH(1,K2) = DH(1,K2) - DH1 DH(2,K2) = DH(2,K2) - DH2 DH(3,K2) = DH(3,K2) - DH3 DH(1,K) = DH1 + DH1 DH(2,K) = DH2 + DH2 DH(3,K) = DH3 + DH3 ENDIF 20 CONTINUE RETURN END SUBROUTINE DER2C1L (R,A,D2H) C * * * * * * * * * * * * * * * * * * * * * * * * * * * * C 2ND DERIVATIVES OF CUBIC HERMITE IN UNIT COORDINATES C (A C1 ELEMENT, SEE SHPC1L & DERC1L) C * * * * * * * * * * * * * * * * * * * * * * * * * * * * DIMENSION D2H(4) C A = PHYSICAL LENGTH OF ELEMENT 1 -------- 2 --> R C R = LOCAL COORDINATE OF POINT R=0 R=1 C D2H = SECOND DERIVATIVES OF H C D()/DX = D()/DR DR/DX = 1/A * D()/DR C DOF ARE VALUE, SLOPE AT EACH END (WRT X) D2H(1) = 6.*(R+R - 1.)/A**2 D2H(2) = (-4. + 6.*R)/A D2H(3) = 6.*(1. - R - R)/A**2 D2H(4) = (6.*R - 2.)/A RETURN END SUBROUTINE DER2C2L (R,A,D2H) C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C 2ND DERIVATIVES OF FIFTH ORDER HERMITE ELEMENT IN UNIT C COORDINATES ( A C2 ELEMENT, SEE SUBR SHPC2L & DERC2L ) C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * DIMENSION D2H(6) C A = PHYSICAL LENGTH OF ELEMENT 1 -------- 2 --> R C R = LOCAL COORDINATE OF POINT R=0 R=1 C D2H = SECOND DERIVATIVES OF H C D()/DX = D()/DR DR/DX = 1/A * D()/DR C DOF ARE VALUE, SLOPE, 2ND DERIV AT EACH END (WRT X) R3 = R*R*R D2H(1) = 30.*(6.*R**2 - 2.*R - 4.*R3)/A**2 D2H(2) = (-36.*R + 96.*R*R - 60.*R3)/A D2H(3) = 0.5*(2. - 18.*R + 36.*R*R - 20.*R3) D2H(4) = 30.*(2.*R - 6.*R*R + 4.*R3)/A**2 D2H(5) = (84.*R*R - 60.*R3 - 24.*R)/A D2H(6) = 0.5*(6.*R - 24.*R*R + 20.*R3) RETURN END SUBROUTINE DER2C3L (R,A,D2H) C * * * * * * * * * * * * * * * * * * * * * * * * * * * * C 2ND DERIV FOR SEVENTH ORDER HERMITE LINE ELEMENT C ( A C3 ELEMENT, SEE SHPC3L & DERC3L ) C * * * * * * * * * * * * * * * * * * * * * * * * * * * * DIMENSION D2H(8) C A = PHYSICAL LENGTH OF ELEMENT 1 -------- 2 --> R C R = LOCAL COORDINATE OF POINT R=0 R=1 C D()/DX = D()/DR DR/DX = 1/A * D()/DR C D2H = SECOND DERIVATIVES OF SHAPE FUNCTIONS ARRAY C DOF ARE VALUE, SLOPE, 2ND, 3RD DERIV AT EACH END (WRT X) R2 = R*R R3 = R2*R R4 = R2*R2 D2H(1) = 140.*(6.*R2*R3 - 15.*R4 + 12.*R3 - 3.*R2)/A**2 D2H(2) = -(240.*R2 - 900.*R3 + 1080.*R4 - 420.*R3*R2)/A D2H(3) = (1. - 60.*R2 + 200.*R3 - 225.*R4 + 84.*R2*R3) D2H(4) = (R - 8.*R2 + 20.*R3 - 20.*R4 + 7.*R2*R3)*A D2H(5) = 140.*(3.*R2 - 12.*R3 + 15.*R4 - 6.*R2*R3)/A**2 D2H(6) = (420.*R3*R2 - 1020.*R4 + 780.*R3 - 180.*R2)/A D2H(7) = (30.*R2 - 140.*R3 + 195.*R4 - 84.*R3*R2) D2H(8) = (7.*R3*R2 - 15.*R4 + 10.*R3 - 2.*R2)*A RETURN END SUBROUTINE DER2CU (B, A, D2H) C * * * * * * * * * * * * * * * * * * * * * * * * C SECOND DERIVATIVES OF SHAPE FUNCTIONS FOR 1-D C CUBIC HERMITE ELEMENT (A C1 ELEMENT) C * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8 (A-H,O-Z) DIMENSION D2H(4) C A = LENGTH OF ELEMENT (SEE SUBR SHPCU) C B = COORDINATE OF POINT C D2H = SECOND DERIVATIVES OF H D2H(1) = (12.*B - 6.)/A/A D2H(2) = (6.*B - 4.)/A D2H(3) = (6. - 12.*B)/A/A D2H(4) = (6.*B - 2.)/A RETURN END SUBROUTINE DER2L (R,DH) C * * * * * * * * * * * * * * * * * * * * * * * * * C DERIVATIVES OF A 2 NODE LINE ELEMENT C * * * * * * * * * * * * * * * * * * * * * * * * * DIMENSION DH(2) C R IS UNIT COORD. R=-1 1------------2 R=1 DH(1) = -0.5 DH(2) = 0.5 RETURN END SUBROUTINE DER3L (X, DH) C * * * * * * * * * * * * * * * * * * * * * * * * * * C FIND LOCAL DERIVATIVES FOR A 3 NODE LINE ELEMENT C IN NATURAL COORDINATES C * * * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8 (A-H,O-Z) DIMENSION DH(3) C DH = LOCAL DERIVATIVES OF SHAPE FUNCTIONS (SHP3L) C X = LOCAL COORDINATE OF POINT, -1 TO +1 C LOCAL NODE COORD. ARE -1,0,+1. 1----2----3 DH(1) = X - 0.5 DH(2) = -2.*X DH(3) = X + 0.5 RETURN END SUBROUTINE DER3T (S, T, DH) C * * * * * * * * * * * * * * * * * * * * * * * * * * C LOCAL DERIVATIVES OF A THREE NODE UNIT TRIANGLE C SEE SUBROUTINE SHP3T C * * * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8 (A-H,O-Z) DIMENSION DH(2,3) C S,T = LOCAL COORDINATES OF THE POINT C DH(1,K) = DH(K)/DS C DH(2,K) = DH(K)/DT C NODAL COORDS ARE : 1-(0,0) 2-(1,0) 3-(0,1) DH(1,1) = -1. DH(1,2) = 1. DH(1,3) = 0.0 DH(2,1) = -1. DH(2,2) = 0.0 DH(2,3) = 1. RETURN END SUBROUTINE DER4Q (R, S, DELTA) C * * * * * * * * * * * * * * * * * * * * * * * * * * C LOCAL DERIVATIVES OF THE SHAPE FUNCTIONS FOR AN C ISOPARAMETRIC QUADRILATERAL WITH FOUR NODES C SEE SHP4Q C * * * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8 (A-H,O-Z) DIMENSION DELTA(2,4) C DELTA(1,I) = DH/DR C DELTA(2,I) = DH/DS C H = LOCAL INTERPOLATION FUNCTIONS C (R,S) = A POINT IN THE LOCAL COORDINATES C HERE D(H(I))/DR = 0.25*R(I)*(1+S*S(I)), ETC. RP = 1. + R RM = 1. - R SP = 1. + S SM = 1. - S DELTA(1,1) = -0.25*SM DELTA(1,2) = 0.25*SM DELTA(1,3) = 0.25*SP DELTA(1,4) = -0.25*SP DELTA(2,1) = -0.25*RM DELTA(2,2) = -0.25*RP DELTA(2,3) = 0.25*RP DELTA(2,4) = 0.25*RM RETURN END SUBROUTINE DER6T (S,T,DH) C * * * * * * * * * * * * * * * * * * * * * * * * * * C LOCAL DERIVATIVES FOR A SIX NODE UNIT TRIANGLE C * * * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8 (A-H,O-Z) DIMENSION DH(2,6) C S,T = LOCAL COORDINATES, SEE SHP6T C DH = LOCAL DERIVATIVES OF SHAPE FUNCTIONS C DH(1,K) = DH(K)/DS, DH(2,K)=DH(K)/DT C NODAL COORDS : 1-(0,0) 2-(1,0) 3-(0,1) C 4-(0.5,0) 5-(0.5,0.5) 6-(0,0.5) DH(1,1) = -3. + 4.*S + 4.*T DH(1,2) = -1. + 4.*S DH(1,3) = 0.0 DH(1,4) = 4. - 8.*S - 4.*T DH(1,5) = 4.*T DH(1,6) = -4.*T DH(2,1) = -3. + 4.*S + 4.*T DH(2,2) = 0.0 DH(2,3) = -1. + 4.*T DH(2,4) = -4.*S DH(2,5) = 4.*S DH(2,6) = 4. -4.*S - 8.*T RETURN END SUBROUTINE DER8H (R,S,T,DH) C * * * * * * * * * * * * * * * * * * * * * * * * * * C LOCAL DERIVATIVES FOR EIGHT NODE HEXAHEDRON C * * * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8 (A-H,O-Z) DIMENSION DH(3,8) C R,S,T = LOCAL COORDINATES OF THE POINT C DH(1,K)=DH/DR, DH(2,K)=DH/DS, DH(3,K)=DH/DT C H = ELEMENT SHAPE FUNCTIONS, SEE SHP8H RP = 1. + R RM = 1. - R SP = 1. + S SM = 1. - S TP = 1. + T TM = 1. - T DH(1,1) = 0.125*SP*TP DH(2,1) = 0.125*RP*TP DH(3,1) = 0.125*RP*SP DH(1,2) = 0.125*SM*TP DH(2,2) = -0.125*RP*TP DH(3,2) = 0.125*RP*SM DH(1,3) = 0.125*SM*TM DH(2,3) = -0.125*RP*TM DH(3,3) = -0.125*RP*SM DH(1,4) = 0.125*SP*TM DH(2,4) = 0.125*RP*TM DH(3,4) = -0.125*RP*SP DH(1,5) = -0.125*SP*TP DH(2,5) = 0.125*RM*TP DH(3,5) = 0.125*RM*SP DH(1,6) = -0.125*SM*TP DH(2,6) = -0.125*RM*TP DH(3,6) = 0.125*RM*SM DH(1,7) = -0.125*SM*TM DH(2,7) = -0.125*RM*TM DH(3,7) = -0.125*RM*SM DH(1,8) = -0.125*SP*TM DH(2,8) = 0.125*RM*TM DH(3,8) = -0.125*RM*SP RETURN END SUBROUTINE DER8Q (S,T,DH) C * * * * * * * * * * * * * * * * * * * * * * * * * * C FIND LOCAL DERIVATIVES OF SHAPE FUNCTIONS FOR AN C EIGHT NODE ISOPARAMETRIC QUADRILATERAL ELEMENT C * * * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8 (A-H,O-Z) DIMENSION DH(2,8) C S,T = LOCAL COORDINATES OF POINT, SEE SHP8Q C DH = LOCAL DERIVATIVES OF SHAPE FUNCTIONS, H C DH(1,J) = DH(J)/DS, DH(2,J) = DH(J)/DT C H = SHAPE FUNCTION ARRAY SP = 1. + S SM = 1. - S TP = 1. + T TM = 1. - T DH(1,1) = -0.25*TM*( SM + SM + TM - 3. ) DH(2,1) = -0.25*SM*( TM + SM + TM - 3. ) DH(1,2) = 0.25*TM*( SP + SP + TM - 3. ) DH(2,2) = -0.25*SP*( TM + SP + TM - 3. ) DH(1,3) = 0.25*TP*( SP + SP + TP - 3. ) DH(2,3) = 0.25*SP*( TP + SP + TP - 3. ) DH(1,4) = -0.25*TP*( SM + SM + TP - 3. ) DH(2,4) = 0.25*SM*( TP + SM + TP - 3. ) DH(1,5) = -S*TM DH(2,5) = -0.5*( 1. - S*S ) DH(1,6) = 0.5*( 1. - T*T ) DH(2,6) = -T*SP DH(1,7) = -S*TP DH(2,7) = 0.5*( 1. - S*S ) DH(1,8) = -0.5*( 1. - T*T ) DH(2,8) = -T*SM RETURN END SUBROUTINE DER9Q ( R, S, DH ) C * * * * * * * * * * * * * * * * * * * * * * * C LOCAL DERIVATIVES FOR 9-NODED QUAD C * * * * * * * * * * * * * * * * * * * * * * * C SEE SHP9Q FOR TOPOLOGY CDP IMPLICIT REAL*8 (A-H,O-Z) DIMENSION DH(2,9) RM = R - 1.D0 SM = S - 1.D0 RP = R + 1.D0 SP = S + 1.D0 S2P1 = S + S + 1.D0 S2M1 = S + S - 1.D0 R2P1 = R + R + 1.D0 R2M1 = R + R - 1.D0 DH(1,1) = 0.25D0 * S * SM * R2M1 DH(1,2) = 0.25D0 * S * SM * R2P1 DH(1,3) = 0.25D0 * S * SP * R2P1 DH(1,4) = 0.25D0 * S * SP * R2M1 DH(1,5) = -S * SM * R DH(1,6) = -0.5D0 * SP * SM * R2P1 DH(1,7) = -S * SP * R DH(1,8) = -0.5D0 * SP * SM * R2M1 DH(1,9) = 2.D0 * SP * SM * R DH(2,1) = 0.25D0 * S2M1 * R * RM DH(2,2) = 0.25D0 * S2M1 * R * RP DH(2,3) = 0.25D0 * S2P1 * R * RP DH(2,4) = 0.25D0 * S2P1 * R * RM DH(2,5) = -0.5D0 * S2M1 * RP * RM DH(2,6) = -S * R * RP DH(2,7) = -0.5D0 * S2P1 * RP * RM DH(2,8) = -S * R * RM DH(2,9) = 2.D0 * S * RP * RM RETURN END SUBROUTINE DERC0L (R, A, DH) C * * * * * * * * * * * * * * * * * * * * * * * * * * * * C FIRST DERIVATIVE OF C0 LINE ELEMENT IN UNIT COORDINATES C (SEE SHPC0L) C * * * * * * * * * * * * * * * * * * * * * * * * * * * * DIMENSION DH(2) C A = PHYSICAL LENGTH OF ELEMENT 1 -------- 2 --> R C R = LOCAL COORDINATE OF POINT R=0 R=1 C DH = FIRST PHYSICAL DERIVATIVES OF H C D()/DX = D()/DR DR/DX = 1/A * D()/DR C DOF ARE NODAL VALUES ONLY DH(1) = -1./A DH(2) = 1./A RETURN END SUBROUTINE DERC1L (R,A,DH) C * * * * * * * * * * * * * * * * * * * * * * * * * * * * C FIRST DERIVATIVES OF CUBIC HERMITE IN UNIT COORDINATES C (A C1 ELEMENT, SEE SHPC1L) C * * * * * * * * * * * * * * * * * * * * * * * * * * * * DIMENSION DH(4) C A = PHYSICAL LENGTH OF ELEMENT 1 -------- 2 --> R C R = LOCAL COORDINATE OF POINT R=0 R=1 C DH = FIRST PHYSICAL DERIVATIVES OF H C D()/DX = D()/DR DR/DX = 1/A * D()/DR C DOF ARE FUNCTION AND SLOPE, D/DX, AT EACH NODE DH(1) = 6.0*(R*R - R)/A DH(2) = 1.0 - 4.0*R + 3.0*R*R DH(3) = 6.0*(R - R*R)/A DH(4) = 3.0*R*R - 2.0*R RETURN END SUBROUTINE DERC2L (R,A,DH) C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C FIRST DERIVATIVES OF FIFTH ORDER HERMITE ELEMENT IN UNIT C COORDINATES ( A C2 ELEMENT, SEE SURR SHPC2L ) C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * DIMENSION DH(6) C A = PHYSICAL LENGTH OF ELEMENT 1 -------- 2 --> R C R = LOCAL COORDINATE OF POINT R=0 R=1 C DH = FIRST PHYSICAL DERIVATIVES OF H C D()/DX = D()/DR DR/DX = 1/A * D()/DR C DOF ARE VALUE, SLOPE, CURVATURE AT EACH NODE (WRT X) R3 = R*R*R DH(1) = 30.*(2.*R3 - R*R - R3*R)/A DH(2) = 1. - 18.*R*R + 32.*R3 - 15.*R3*R DH(3) = 0.5*(2.*R - 9.*R*R + 12.*R3 - 5.*R3*R)*A DH(4) = 30.*R*R*(1. - 2.*R + R*R)/A DH(5) = 28.*R3 - 15.*R3*R - 12.*R*R DH(6) = 0.5*R*R*(3. - 8.*R + 5.*R*R)*A RETURN END SUBROUTINE DERC3L (R,A,DH) C * * * * * * * * * * * * * * * * * * * * * * * * * * * * C FIRST DERIVATIVES FOR 7TH ORDER HERMITE LINE ELEMENT C ( A C3 ELEMENT, SEE SHPC3L ) C * * * * * * * * * * * * * * * * * * * * * * * * * * * * DIMENSION DH(8) C A = PHYSICAL LENGTH OF ELEMENT 1 -------- 2 --> R C R = LOCAL COORDINATE OF POINT R=0 R=1 C DH = FIRST PHYSICAL DERIVATIVES OF H C D()/DX = D()/DR DR/DX = 1/A * D()/DR C DOF ARE VALUE, SLOPE, 2ND, 3RD DERIV AT EACH END (WRT X) R2 = R*R R3 = R2*R R4 = R2*R2 DH(1) = 140.*R3*(R3 - 3.*R2 + 3.*R - 1.)/A DH(2) = 1. - R3*(80. - 225.*R + 216.*R2 - 70.*R3) DH(3) = R*(1. - 20.*R2 + 50.*R3 - 45.*R4 + 14.*R2*R3)*A DH(4) = R2*(3. - 16.*R + 30.*R2 - 24.*R3 + 7.*R4)*A*A/6. DH(5) = 140.*R3*(1. - 3.*R + 3.*R2 - R3)/A DH(6) = R3*(70.*R3 - 204.*R2 + 195.*R - 60.) DH(7) = R3*(10. - 35.*R + 39.*R2 - 14.*R3)*A DH(8) = R3*(7.*R3 - 18.*R2 + 15.*R - 4.)*A*A/6. RETURN END SUBROUTINE DERCU (B, A, DH) C * * * * * * * * * * * * * * * * * * * * * * * * C FIRST DERIVATIVES OF SHAPE FUNCTIONS FOR 1-D C CUBIC HERMITE ELEMENT (A C1 ELEMENT) C * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8 (A-H,O-Z) DIMENSION DH(4) C A = LENGTH OF ELEMENT (SEE SUBR SHPCU) C B = COORDINATE OF POINT C DH = FIRST DERIVATIVES OF H DH(1) = 6.*(B*B - B)/A DH(2) = 1. - 4.*B + 3.*B*B DH(3) = 6.*(B - B*B)/A DH(4) = 3.*B*B - 2.*B RETURN END SUBROUTINE DERHQL (NODEDG, LOCATE, NEDGE, LEDGES, NSPACE, & RST, DERIV) C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C SHAPE FUNCTION DERIVATIVES FOR GENERAL SERENDIPITY C LINE, QUAD, OR OR HEXAHEDRON WITH AN C ARBITRARY NUMBER OF NODES ON EACH EDGE C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8 (A-H,O-Z) PARAMETER ( MAXDEG = 20 ) DIMENSION RST(3), BLKCRD(3,8), POLI2(3), CDRFN(3), & FARSID(3), DERIV(3), CRDEDG(3,MAXDEG+1), & NODEDG(12), NEATC(3,8), NODEOP(2,12), & NODATC(3), LOCAL(12) DATA BLKCRD &/ -1.,-1.,-1., 1.,-1.,-1., 1.,1.,-1., -1.,1.,-1., & -1.,-1., 1., 1.,-1., 1., 1.,1., 1., -1.,1., 1./ DATA NEATC / 1,4,9, 1,2,10, 3,2,11, 3,4,12, & 5,8,9, 5,6,10, 7,6,11, 7,8,12 / DATA NODEOP / 7,8, 8,5, 5,6, 6,7, & 3,4, 4,1, 1,2, 2,3, & 3,7, 4,8, 1,5, 2,6 / DATA LOCAL / -1, -2, 1, 2, -1, -2, 1, 2, -3, -3, -3, -3 / C BLKCRD = BLOCK CORNER LOCAL COORDINATES C CRDEDG = LOCAL COORDINATES OF SIDE NODES JOINING CORNER C FARSID = FAR SIDE LOCAL COORDINATE C LEDGES = NUMBER OF ELEMENT EDGES, 1, 4, OR 12 C LOCAL = LOCAL COORDINATE PARALLEL TO EACH EDGE C LOCATE = POSITION NUMBER ON EDGE, 0 IF CORNER C MAXDEG = MAXIMUM PLOYNOMIAL DEGREE ON ANY SIDE C NEATC = THE 1, 2, OR 3 EDGES AT A CORNER C NEDGE = EDGE NUMBER OR CORNER NUMBER OF THE NODE COMPUTED C NODATC = NUMBER OF SIDE NODES JOINING A CORNER C NODEDG = NUMBER ON NODES ON 1,4, OR 12 EDGES C NODEOP = 2 DIAGONALLY OPPOSITE NODES FOR EACH EDGE C NSPACE = NUMBER OF SPATIAL DIMENSIONS C RST = LOCAL COORDINATES FOR EVALUATION C VALUE = SHAPE FUNCTION VALUE (RETURNED) C C VALUE = A(R,S,T)*( P1(R) + P2(S) + P3(T) + CONSTANT ) C DERIV = DA(R,S,T)*( P1(R) + P2(S) + P3(T) + CONSTANT ) C + A(R,S,T)*( DP1(R) + DP2(S) + DP3(T) ) C C REF: G. ZAVARISE, ET AL, "AN ALGORITHM FOR GENERATION OF SHAPE C FUNCTIONS IN SERENDIPITY ELEMENTS", ENG COMP,8,19-31,1991 C C T: S C8 *---E7----* C7 T: S 8---15----7 C : / /. /: : / /. /: C :/ / . / : :/ / 22 / : C *---R / E12 / E11 *---R / . / 20 C E8 . E6 : 16 21 / : C / . / : / . / : C / C4*.../.E3..* C3 / 4.13/.12..3 C / . / / / . / / C C5 *--E5-----* C6 / 5---------6 / C : . : / : . : 11 C : E4 : E2 : 14 19 / C E9 . E10 / 17 . : 10 C : . : / : . 18 / C :. :/ :. :/ C C1 *---E1----* C2 1----9----2 C CORNER NODE & EDGE NUMBERS. 22 NODES: CORNERS, THEN BY EDGES. C CCW IF |T|=1, ELSE IN POSITIVE T. C === 3-D FORM === C C C4 *---E3----* C3 4----8----3 C : . : :S : : C : : : : : C E4 E2 : 9 : C : : *---R : : C : : : : C C1 *---E1----* C2 1--5-6-7--2 C CORNER NODE & EDGE NUMBERS. 9 NODES: CORNERS, THEN BY EDGE ORDER. C === 2-D FORM === C C C1 *---E1----* C2 1--2-3-4--5 C CORNER NODE & EDGE NUMBERS. 9 NODES NUMBERED BY EDGE ORDER. C === 1-D FORM === POLI1 = 1. IF ( LOCATE .EQ. 0 ) THEN C C SHAPE FUNCTION FOR CORNER NODES C DO 100 ICORD = 1,NSPACE POLI1 = POLI1*(RST(ICORD) + BLKCRD(ICORD,NEDGE)) & /(2*BLKCRD(ICORD,NEDGE)) 100 CONTINUE CPNUL = 1. POLI2(1) = 0. POLI2(2) = 0. POLI2(3) = 0. DO 200 ICORD = 1,NSPACE NSIDE = NEATC(ICORD,NEDGE) NODATC(ICORD) = NODEDG(NSIDE) - 2 IF ( NODATC(ICORD) .GT. 0 ) THEN IF ( NODATC(ICORD) .GT. MAXDEG ) STOP 'MAXDEG, DERSHAFN' CPNUL = CPNUL - 1. POLI2(ICORD) = 1. FARSID(ICORD) = 2./(NODEDG(NSIDE) - 1) DO 300 INODE = 1,NODATC(ICORD) CRDEDG(ICORD,INODE) = -1. + FARSID(ICORD)*INODE POLI2(ICORD) = POLI2(ICORD)*(RST(ICORD) & - CRDEDG(ICORD,INODE))/(BLKCRD(ICORD,NEDGE) & - CRDEDG(ICORD,INODE)) 300 CONTINUE ENDIF 200 CONTINUE C VALUE = POLI1*(POLI2(1) + POLI2(2) + POLI2(3) + CPNUL) ELSE C C SHAPE FUNCTION FOR EDGE NODES C NOPV1 = NODEOP(1,NEDGE) NOPV2 = NODEOP(2,NEDGE) ISRFN = ABS(LOCAL(NEDGE)) FARSID(1) = 2./(NODEDG(NEDGE) - 1) CDRFN(1) = -BLKCRD(1,NOPV1) CDRFN(2) = -BLKCRD(2,NOPV1) CDRFN(3) = -BLKCRD(3,NOPV1) CDRFN(ISRFN) = (1. - FARSID(1)*LOCATE)*LOCAL(NEDGE)/ISRFN DO 400 ICORD = 1,NSPACE POLI1 = POLI1*(RST(ICORD) - BLKCRD(ICORD,NOPV1)) & /(CDRFN(ICORD) - BLKCRD(ICORD,NOPV1)) 400 CONTINUE PLAN2 = (RST(ISRFN) - BLKCRD(ISRFN,NOPV2)) & /(CDRFN(ISRFN) - BLKCRD(ISRFN,NOPV2)) POLI3 = 1. NODATC(1) = NODEDG(NEDGE) - 2 IF ( NODATC(1) .GT. 0 ) THEN IF ( NODATC(1) .GT. MAXDEG ) STOP 'MAXDEG, DERSHAFN' DO 500 INODE = 1,NODATC(1) CRDEDG(1,INODE) = -1. + FARSID(1)*INODE IF ( ABS(CRDEDG(1,INODE) - CDRFN(ISRFN)) .GT. 0.0001) & THEN POLI3 = POLI3*(RST(ISRFN) - CRDEDG(1,INODE)) & /(CDRFN(ISRFN) - CRDEDG(1,INODE)) ENDIF 500 CONTINUE ENDIF C VALUE = POLI1*PLAN2*POLI3 ENDIF C C DERIVATIVES OF SHAPE FUNCTIONS C DO 600 ICOR1 = 1,NSPACE IF ( LOCATE .EQ. 0 ) THEN C C DERIVATIVES FOR CORNER NODES C DPOL1 = POLI2(1) + POLI2(2) + POLI2(3) + CPNUL DO 700 ICOR2 = 1,NSPACE IF ( ICOR2 .NE. ICOR1 ) THEN DPOL1 = DPOL1*(RST(ICOR2) + BLKCRD(ICOR2,NEDGE)) & /(2*BLKCRD(ICOR2,NEDGE)) ELSE DPOL1 = DPOL1/(2*BLKCRD(ICOR2,NEDGE)) ENDIF 700 CONTINUE DPOL2 = 0. DO 800 INOD1 = 1,NODATC(ICOR1) DETP2 = 1. DO 900 INOD2 = 1,NODATC(ICOR1) IF ( INOD2 .NE. INOD1 ) THEN DETP2 = DETP2*(RST(ICOR1) - CRDEDG(ICOR1,INOD2)) & /(BLKCRD(ICOR1,NEDGE) - CRDEDG(ICOR1,INOD2)) ELSE DETP2 = DETP2/(BLKCRD(ICOR1,NEDGE) & - CRDEDG(ICOR1,INOD2)) ENDIF 900 CONTINUE DPOL2 = DPOL2 + DETP2 800 CONTINUE DPOL2 = DPOL2*POLI1 DERIV(ICOR1) = DPOL1 + DPOL2 ELSE C C DERIVATIVES FOR EDGE NODES C DPOL1 = POLI3*PLAN2 DO 1000 ICOR2 = 1,NSPACE IF ( ICOR2 .NE. ICOR1 ) THEN DPOL1 = DPOL1*(RST(ICOR2) - BLKCRD(ICOR2,NOPV1)) & /(CDRFN(ICOR2) - BLKCRD(ICOR2,NOPV1)) ELSE DPOL1 = DPOL1/(CDRFN(ICOR2) - BLKCRD(ICOR2,NOPV1)) ENDIF 1000 CONTINUE DPLA2 = 0. DPOL3 = 0. IF ( ICOR1 .EQ. ISRFN ) THEN DPLA2 = POLI1*POLI3/(CDRFN(ISRFN) - BLKCRD(ISRFN,NOPV2)) DO 1100 INOD1 = 1,NODATC(1) IF ( ABS(CRDEDG(1,INOD1) - CDRFN(ISRFN)) .GT. 0.0001) & THEN DETP3 = 1. DO 1200 INOD2 = 1,NODATC(1) IF ( ABS(CRDEDG(1,INOD2) - CDRFN(ISRFN)) .GT. & 0.0001 ) THEN IF ( INOD2 .NE. INOD1 ) THEN DETP3 = DETP3*(RST(ISRFN) - CRDEDG(1,INOD2)) & /(CDRFN(ISRFN) - CRDEDG(1,INOD2)) ELSE DETP3 = DETP3/(CDRFN(ISRFN) - CRDEDG(1,INOD2)) ENDIF ENDIF 1200 CONTINUE DPOL3 = DPOL3 + DETP3 ENDIF 1100 CONTINUE DPOL3 = DPOL3*POLI1*PLAN2 ENDIF DERIV(ICOR1) = DPOL1 + DPLA2 + DPOL3 ENDIF 600 CONTINUE RETURN END SUBROUTINE DERIV (PT, DLH, N, NSPACE, LSHAPE, NG, LNODE) C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C EVALUATE C0 INTERPOLATION LOCAL DERIVATIVES C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8 (A-H,O-Z) cb DIMENSION DLH(NSPACE,N), PT(NSPACE), LNODE(N) DIMENSION DLH(NSPACE,N*NG), PT(NSPACE), LNODE(N) C DLH = LOCAL DERIVATIVES AT PT C LNODE = TOPOLOGY LIST, IF VARIABLE C LSHAPE = 1-LINE, 2-TRI, 3-QUAD, 4-HEX, 5-TET, 6-WEDGE C N = NUMBER OF NODES PER ELEMENT C NG = NUMBER OF DEGREES OF FREEDOM PER NODE C NSPACE = NO OF SPATIAL DIMENSIONS C PT = LOCAL COORD OF A POINT C C BRANCH ON SHAPE, THEN NUMBER OF NODES IF ( LSHAPE .LE. 1 ) THEN C--> 1-D ELEMENTS IF ( N .EQ. 2 ) CALL DER2L (PT(1),DLH) c IF ( N .EQ. 3 ) CALL DER3L (PT(1),DLH) RETURN ELSEIF ( LSHAPE .EQ. 2 ) THEN C--> TRIANGULAR 2-D ELEMENTS IF ( N .EQ. 3 ) CALL DER3T (PT(1),PT(2),DLH) C IF ( N .EQ. 4 ) CALL DER4T (PT(1),PT(2),DLH) IF ( N .EQ. 6 ) CALL DER6T (PT(1),PT(2),DLH) C IF ( N .EQ. 7 ) CALL DER7T (PT(1),PT(2),DLH) C IF ( N .EQ. 10 ) CALL DER10T (PT(1),PT(2),DLH) C IF ( N .EQ. 15 ) CALL DER15T (PT(1),PT(2),DLH) RETURN ELSEIF ( LSHAPE .EQ. 3 ) THEN C--> QUADRILATERAL 2-D ELEMENTS IF ( N .EQ. 4 ) CALL DER4Q (PT(1),PT(2),DLH) IF ( N .EQ. 8 ) CALL DER8Q (PT(1),PT(2),DLH) IF ( N .EQ. 9 ) CALL DER9Q (PT(1),PT(2),DLH) C IF ( N .EQ. 12 ) CALL DER412 (PT(1),PT(2),DLH,LNODE) C IF ( N .EQ. 16 ) CALL DER16Q (PT(1),PT(2),DLH) C IF ( N .EQ. 17 ) CALL DER17Q (PT(1),PT(2),DLH) C IF ( N .EQ. 25 ) CALL DER25Q (PT(1),PT(2),DLH) RETURN ELSEIF ( LSHAPE .EQ. 4 ) THEN C--> HEXAHEDRA 3-D ELEMENTS IF ( N .EQ. 8 ) CALL DER8H (PT(1),PT(2),PT(3),DLH) c IF ( N .EQ. 20 ) CALL DER208 (PT(1),PT(2),PT(3),DLH,LNODE) C IF ( N .EQ. 27 ) CALL DER27H (PT(1),PT(2),PT(3),DLH) C IF ( N .EQ. 32 ) CALL DER32H (PT(1),PT(2),PT(3),DLH) RETURN ELSEIF ( LSHAPE .EQ. 5 ) THEN C--> TETRAHEDRA 3-D ELEMENTS (PYRAMIDS) c IF ( N .EQ. 4 ) CALL DER4P (PT(1),PT(2),PT(3),DLH) C IF ( N .EQ. 10 ) CALL DER10P (PT(1),PT(2),PT(3),DLH) C IF ( N .EQ. 21 ) CALL DER21P (PT(1),PT(2),PT(3),DLH) RETURN ELSEIF ( LSHAPE .EQ. 6 ) THEN C--> WEDGE 3-D ELEMENTS STOP 'NO WEDGE IN SHAPE' C IF ( N .EQ. 6 ) CALL DER6W (PT(1),PT(2),PT(3),DLH) C IF ( N .EQ. 15 ) CALL DER15W (PT(1),PT(2),PT(3),DLH) C RETURN ELSEIF ( LSHAPE .EQ. 7 ) THEN C--> USER SUPPLIED ELEMENT C CALL DERUSR (PT(1),PT(2),PT(3),DLH,LNODE) STOP 'NO USER ELEMENT IN DERIV' ELSEIF ( LSHAPE .GT. 7 ) THEN C--> UNSUPPORTED OPTION STOP 'UNSUPPORTED ELEMENT IN DERIV' ENDIF RETURN END SUBROUTINE DERSHPH (NODEDG, LOCATE, NEDGE, LEDGES, NSPACE, & RST, VALUE, DERIV) C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C SHAPE FUNCTIONS AND DERIVATIVES FOR GENERAL SERENDIPITY C LINE, QUAD, OR OR HEXAHEDRON WITH AN C ARBITRARY NUMBER OF NODES ON EACH EDGE C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8 (A-H,O-Z) PARAMETER ( MAXDEG = 20 ) DIMENSION RST(3), BLKCRD(3,8), POLI2(3), CDRFN(3), & FARSID(3), DERIV(3), CRDEDG(3,MAXDEG+1), & NODEDG(12), NEATC(3,8), NODEOP(2,12), & NODATC(3), LOCAL(12) DATA BLKCRD &/ -1.,-1.,-1., 1.,-1.,-1., 1.,1.,-1., -1.,1.,-1., & -1.,-1., 1., 1.,-1., 1., 1.,1., 1., -1.,1., 1./ DATA NEATC / 1,4,9, 1,2,10, 3,2,11, 3,4,12, & 5,8,9, 5,6,10, 7,6,11, 7,8,12 / DATA NODEOP / 7,8, 8,5, 5,6, 6,7, & 3,4, 4,1, 1,2, 2,3, & 3,7, 4,8, 1,5, 2,6 / DATA LOCAL / -1, -2, 1, 2, -1, -2, 1, 2, -3, -3, -3, -3 / C BLKCRD = BLOCK CORNER LOCAL COORDINATES C CRDEDG = LOCAL COORDINATES OF SIDE NODES JOINING CORNER C DERIV = SHAPE FUNCTION DERIVATIVES (RETURNED) C FARSID = FAR SIDE LOCAL COORDINATE C LEDGES = NUMBER OF ELEMENT EDGES, 1, 4, OR 12 C LOCAL = LOCAL COORDINATE PARALLEL TO EACH EDGE C LOCATE = POSITION NUMBER ON EDGE, 0 IF CORNER C MAXDEG = MAXIMUM PLOYNOMIAL DEGREE ON ANY SIDE C NEATC = THE 1, 2, OR 3 EDGES AT A CORNER C NEDGE = EDGE NUMBER OR CORNER NUMBER OF THE NODE COMPUTED C NODATC = NUMBER OF SIDE NODES JOINING A CORNER C NODEDG = NUMBER ON NODES ON 1,4, OR 12 EDGES C NODEOP = 2 DIAGONALLY OPPOSITE NODES FOR EACH EDGE C NSPACE = NUMBER OF SPATIAL DIMENSIONS C RST = LOCAL COORDINATES FOR EVALUATION C VALUE = SHAPE FUNCTION VALUE (RETURNED) C C VALUE = A(R,S,T)*( P1(R) + P2(S) + P3(T) + CONSTANT ) C DERIV = DA(R,S,T)*( P1(R) + P2(S) + P3(T) + CONSTANT ) C + A(R,S,T)*( DP1(R) + DP2(S) + DP3(T) ) C C REF: G. ZAVARISE, ET AL, "AN ALGORITHM FOR GENERATION OF SHAPE C FUNCTIONS IN SERENDIPITY ELEMENTS, I.J.N.M.E." C C T: S C8 *---E7----* C7 T: S 8---15----7 C : / /. /: : / /. /: C :/ / . / : :/ / 22 / : C *---R / E12 / E11 *---R / . / 20 C E8 . E6 : 16 21 / : C / . / : / . / : C / C4*.../.E3..* C3 / 4.13/.12..3 C / . / / / . / / C C5 *--E5-----* C6 / 5---------6 / C : . : / : . : 11 C : E4 : E2 : 14 19 / C E9 . E10 / 17 . : 10 C : . : / : . 18 / C :. :/ :. :/ C C1 *---E1----* C2 1----9----2 C CORNER NODE & EDGE NUMBERS. 22 NODES: CORNERS, THEN BY EDGES. C CCW IF |T|=1, ELSE IN POSITIVE T. C === 3-D FORM === C C C4 *---E3----* C3 4----8----3 C : . : :S : : C : : : : : C E4 E2 : 9 : C : : *---R : : C : : : : C C1 *---E1----* C2 1--5-6-7--2 C CORNER NODE & EDGE NUMBERS. 9 NODES: CORNERS, THEN BY EDGE ORDER. C === 2-D FORM === C C C1 *---E1----* C2 1--2-3-4--5 C CORNER NODE & EDGE NUMBERS. 9 NODES NUMBERED BY EDGE ORDER. C === 1-D FORM === POLI1 = 1. IF ( LOCATE .EQ. 0 ) THEN C C SHAPE FUNCTION FOR CORNER NODES C DO 100 ICORD = 1,NSPACE POLI1 = POLI1*(RST(ICORD) + BLKCRD(ICORD,NEDGE)) & /(2*BLKCRD(ICORD,NEDGE)) 100 CONTINUE CPNUL = 1. POLI2(1) = 0. POLI2(2) = 0. POLI2(3) = 0. DO 200 ICORD = 1,NSPACE NSIDE = NEATC(ICORD,NEDGE) NODATC(ICORD) = NODEDG(NSIDE) - 2 IF ( NODATC(ICORD) .GT. 0 ) THEN IF ( NODATC(ICORD) .GT. MAXDEG ) STOP 'MAXDEG, DERSHAFN' CPNUL = CPNUL - 1. POLI2(ICORD) = 1. FARSID(ICORD) = 2./(NODEDG(NSIDE) - 1) DO 300 INODE = 1,NODATC(ICORD) CRDEDG(ICORD,INODE) = -1. + FARSID(ICORD)*INODE POLI2(ICORD) = POLI2(ICORD)*(RST(ICORD) & - CRDEDG(ICORD,INODE))/(BLKCRD(ICORD,NEDGE) & - CRDEDG(ICORD,INODE)) 300 CONTINUE ENDIF 200 CONTINUE VALUE = POLI1*(POLI2(1) + POLI2(2) + POLI2(3) + CPNUL) ELSE C C SHAPE FUNCTION FOR EDGE NODES C NOPV1 = NODEOP(1,NEDGE) NOPV2 = NODEOP(2,NEDGE) ISRFN = ABS(LOCAL(NEDGE)) FARSID(1) = 2./(NODEDG(NEDGE) - 1) CDRFN(1) = -BLKCRD(1,NOPV1) CDRFN(2) = -BLKCRD(2,NOPV1) CDRFN(3) = -BLKCRD(3,NOPV1) CDRFN(ISRFN) = (1. - FARSID(1)*LOCATE)*LOCAL(NEDGE)/ISRFN DO 400 ICORD = 1,NSPACE POLI1 = POLI1*(RST(ICORD) - BLKCRD(ICORD,NOPV1)) & /(CDRFN(ICORD) - BLKCRD(ICORD,NOPV1)) 400 CONTINUE PLAN2 = (RST(ISRFN) - BLKCRD(ISRFN,NOPV2)) & /(CDRFN(ISRFN) - BLKCRD(ISRFN,NOPV2)) POLI3 = 1. NODATC(1) = NODEDG(NEDGE) - 2 IF ( NODATC(1) .GT. 0 ) THEN IF ( NODATC(1) .GT. MAXDEG ) STOP 'MAXDEG, DERSHAFN' DO 500 INODE = 1,NODATC(1) CRDEDG(1,INODE) = -1. + FARSID(1)*INODE IF ( ABS(CRDEDG(1,INODE) - CDRFN(ISRFN)) .GT. 0.0001) & THEN POLI3 = POLI3*(RST(ISRFN) - CRDEDG(1,INODE)) & /(CDRFN(ISRFN) - CRDEDG(1,INODE)) ENDIF 500 CONTINUE ENDIF VALUE = POLI1*PLAN2*POLI3 ENDIF C C DERIVATIVES OF SHAPE FUNCTIONS C DO 600 ICOR1 = 1,NSPACE IF ( LOCATE .EQ. 0 ) THEN C C DERIVATIVES FOR CORNER NODES C DPOL1 = POLI2(1) + POLI2(2) + POLI2(3) + CPNUL DO 700 ICOR2 = 1,NSPACE IF ( ICOR2 .NE. ICOR1 ) THEN DPOL1 = DPOL1*(RST(ICOR2) + BLKCRD(ICOR2,NEDGE)) & /(2*BLKCRD(ICOR2,NEDGE)) ELSE DPOL1 = DPOL1/(2*BLKCRD(ICOR2,NEDGE)) ENDIF 700 CONTINUE DPOL2 = 0. DO 800 INOD1 = 1,NODATC(ICOR1) DETP2 = 1. DO 900 INOD2 = 1,NODATC(ICOR1) IF ( INOD2 .NE. INOD1 ) THEN DETP2 = DETP2*(RST(ICOR1) - CRDEDG(ICOR1,INOD2)) & /(BLKCRD(ICOR1,NEDGE) - CRDEDG(ICOR1,INOD2)) ELSE DETP2 = DETP2/(BLKCRD(ICOR1,NEDGE) & - CRDEDG(ICOR1,INOD2)) ENDIF 900 CONTINUE DPOL2 = DPOL2 + DETP2 800 CONTINUE DPOL2 = DPOL2*POLI1 DERIV(ICOR1) = DPOL1 + DPOL2 ELSE C C DERIVATIVES FOR EDGE NODES C DPOL1 = POLI3*PLAN2 DO 1000 ICOR2 = 1,NSPACE IF ( ICOR2 .NE. ICOR1 ) THEN DPOL1 = DPOL1*(RST(ICOR2) - BLKCRD(ICOR2,NOPV1)) & /(CDRFN(ICOR2) - BLKCRD(ICOR2,NOPV1)) ELSE DPOL1 = DPOL1/(CDRFN(ICOR2) - BLKCRD(ICOR2,NOPV1)) ENDIF 1000 CONTINUE DPLA2 = 0. DPOL3 = 0. IF ( ICOR1 .EQ. ISRFN ) THEN DPLA2 = POLI1*POLI3/(CDRFN(ISRFN) - BLKCRD(ISRFN,NOPV2)) DO 1100 INOD1 = 1,NODATC(1) IF ( ABS(CRDEDG(1,INOD1) - CDRFN(ISRFN)) .GT. 0.0001) & THEN DETP3 = 1. DO 1200 INOD2 = 1,NODATC(1) IF ( ABS(CRDEDG(1,INOD2) - CDRFN(ISRFN)) .GT. & 0.0001 ) THEN IF ( INOD2 .NE. INOD1 ) THEN DETP3 = DETP3*(RST(ISRFN) - CRDEDG(1,INOD2)) & /(CDRFN(ISRFN) - CRDEDG(1,INOD2)) ELSE DETP3 = DETP3/(CDRFN(ISRFN) - CRDEDG(1,INOD2)) ENDIF ENDIF 1200 CONTINUE DPOL3 = DPOL3 + DETP3 ENDIF 1100 CONTINUE DPOL3 = DPOL3*POLI1*PLAN2 ENDIF DERIV(ICOR1) = DPOL1 + DPLA2 + DPOL3 ENDIF 600 CONTINUE RETURN END FUNCTION DOT (N, A, B) C * * * * * * * * * * * * * * * * * C DOT PRODUCT OF VECTORS A(N)*B(N) C * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8 (A-H,O-Z) DIMENSION A(N), B(N) DOT = 0.0 DO 10 I = 1,N 10 DOT = DOT + A(I)*B(I) RETURN END SUBROUTINE DQRULE (IDEG, NQP, NCORD, PT, WT) C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C DUNAVANT QUADRATURE RULE FOR TRIANGLES, TO DEGREE = 17 C IN AREA COORDINATES (NCORD=3), OR UNIT COORDINATES (NCORD=2) C I.J.N.M.E. VOL. 21, PP.1129-1148, 1985 C INPUT IDEG=0,1,2,3,4,5, 6, 7, 8, 9,10,11,12,13,14,15,16,17,NQP=0 C OR NQP=1,1,3,4,6,7,12,13,16,19,25,27,33,37,42,48,52,61 C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C WARNING: REQUIRES COMPILER FLAG FOR 40 CONTINUATION LINES,-Nl40 <===== CDP IMPLICIT REAL*8 (A-H,O,R-V,X-Z) C PT & WT ARE SINGLE PRECISION PARAMETER ( MAXDEG = 17, MAXDAT = 107 ) DIMENSION PT(NCORD,0:*), WT(0:*) DIMENSION AW(MAXDAT), A1(MAXDAT), A2(MAXDAT), A3(MAXDAT), 1 NQPDEG(MAXDEG), ISTART(MAXDEG), LINES(MAXDEG), 2 KOUNTS(MAXDAT) C IDEG = DEGREE OF POLYNOMIAL TO BE INTEGRATED, 0 TO MAXDEG C NQP = NUMBER OF QUADRATURE POINTS, USE 0 IF IDEG GOVERNS C NCORD = NUMBER OF PARAMETRIC DIMENSIONS: 3-AREA, 2-UNIT CORD C PT = RETURNED QUADRATURE COORDINATES, PT(NCORD,NQP) C WT = RETURNED QUADRATURE WEIGHTS, WT(NQP) C C NQPDEG = NUMBER QUADRATURE PTS FOR POLYNOMIAL DEGREE C ISTART = WHERE IDEG RULE DATA STARTS IN DATA TABLES C LINES = NUMBER OF LINES OF DATA FOR EACH RULE C KOUNTS = NUMBER OF TIMES THAT A RULE LINE IS USED C A1,A2,A3 = AREA COORDINATES OF TABLE POINT C AW = AREA WEIGHT OF TABLE POINT DATA NQPDEG /1,3,4,6,7,12,13,16,19,25,27,33,37,42,48,52,61/ DATA LINES /1,1,2,2,3, 3, 4, 5, 6, 6, 7, 8,10,10,11,13,15/ DATA ISTART /1,2,3,5,7,10,13,17,22,28,34,41,49,59,69,80,93/ DATA KOUNTS /1,3,1,3,3,3,1,3,3,3,3,6,1,3,3,6,1,3,3,3,6,1,3,3,3, 1 3,6,1,3,3,6,6,6,3,3,3,3,3,6,6,3,3,3,3,3,6,6,6,1,3, 2 3,3,3,3,3,6,6,6,3,3,3,3,3,3,6,6,6,6,3,3,3,3,3,3,6, 3 6,6,6,6,1,3,3,3,3,3,3,3,6,6,6,6,6,1,3,3,3,3,3,3,3, 4 3,6,6,6,6,6,6 / DATA AW / + 1.000000000000000, 0.333333333333333, -0.562500000000000, + 0.520833333333333, 0.223381589678011, 0.109951743655322, + 0.225000000000000, 0.132394152788506, 0.125939180544827, + 0.116786275726379, 0.050844906370207, 0.082851075618374, + -0.149570044467682, 0.175615257433208, 0.053347235608838, + 0.077113760890257, 0.144315607677787, 0.095091634267285, + 0.103217370534718, 0.032458497623198, 0.027230314174435, + 0.097135796282799, 0.031334700227139, 0.077827541004774, + 0.079647738927210, 0.025577675658698, 0.043283539377289, + 0.090817990382754, 0.036725957756467, 0.045321059435528, + 0.072757916845420, 0.028327242531057, 0.009421666963733, + 0.000927006328961, 0.077149534914813, 0.059322977380774, + 0.036184540503418, 0.013659731002678, 0.052337111962204, + 0.020707659639141, 0.025731066440455, 0.043692544538038, + 0.062858224217885, 0.034796112930709, 0.006166261051559, + 0.040371557766381, 0.022356773202303, 0.017316231108659, + 0.052520923400802, 0.011280145209330, 0.031423518362454, + 0.047072502504194, 0.047363586536355, 0.031167529045794, + 0.007975771465074, 0.036848402728732, 0.017401463303822, + 0.015521786839045, 0.021883581369429, 0.032788353544125, + 0.051774104507292, 0.042162588736993, 0.014433699669777, + 0.004923403602400, 0.024665753212564, 0.038571510787061, + 0.014436308113534, 0.005010228838501, 0.001916875642849, + 0.044249027271145, 0.051186548718852, 0.023687735870688, + 0.013289775690021, 0.004748916608192, 0.038550072599593, + 0.027215814320624, 0.002182077366797, 0.021505319847731, + 0.007673942631049, 0.046875697427642, 0.006405878578585, + 0.041710296739387, 0.026891484250064, 0.042132522761650, + 0.030000266842773, 0.014200098925024, 0.003582462351273, + 0.032773147460627, 0.015298306248441, 0.002386244192839, + 0.019084792755899, 0.006850054546542, 0.033437199290803, + 0.005093415440507, 0.014670864527638, 0.024350878353672, + 0.031107550868969, 0.031257111218620, 0.024815654339665, + 0.014056073070557, 0.003194676173779, 0.008119655318993, + 0.026805742283163, 0.018459993210822, 0.008476868534328, + 0.018292796770025, 0.006665632004165 / DATA A1 / + 0.333333333333333, 0.666666666666667, 0.333333333333333, + 0.600000000000000, 0.108103018168070, 0.816847572980459, + 0.333333333333333, 0.059715871789770, 0.797426985353087, + 0.501426509658179, 0.873821971016996, 0.053145049844817, + 0.333333333333333, 0.479308067841920, 0.869739794195568, + 0.048690315425316, 0.333333333333333, 0.081414823414554, + 0.658861384496480, 0.898905543365938, 0.008394777409958, + 0.333333333333333, 0.020634961602525, 0.125820817014127, + 0.623592928761935, 0.910540973211095, 0.036838412054736, + 0.333333333333333, 0.028844733232685, 0.781036849029926, + 0.141707219414880, 0.025003534762686, 0.009540815400299, + -0.069222096541517, 0.202061394068290, 0.593380199137435, + 0.761298175434837, 0.935270103777448, 0.050178138310495, + 0.021022016536166, 0.023565220452390, 0.120551215411079, + 0.457579229975768, 0.744847708916828, 0.957365299093579, + 0.115343494534698, 0.022838332222257, 0.025734050548330, + 0.333333333333333, 0.009903630120591, 0.062566729780852, + 0.170957326397447, 0.541200855914337, 0.771151009607340, + 0.950377217273082, 0.094853828379579, 0.018100773278807, + 0.022233076674090, 0.022072179275643, 0.164710561319092, + 0.453044943382323, 0.645588935174913, 0.876400233818255, + 0.961218077502598, 0.057124757403648, 0.092916249356972, + 0.014646950055654, 0.001268330932872, -0.013945833716486, + 0.137187291433955, 0.444612710305711, 0.747070217917492, + 0.858383228050628, 0.962069659517853, 0.133734161966621, + 0.036366677396917, -0.010174883126571, 0.036843869875878, + 0.012459809331199, 0.333333333333333, 0.005238916103123, + 0.173061122901295, 0.059082801866017, 0.518892500060958, + 0.704068411554854, 0.849069624685052, 0.966807194753950, + 0.103575692245252, 0.020083411655416, -0.004341002614139, + 0.041941786468010, 0.014317320230681, 0.333333333333333, + 0.005658918886452, 0.035647354750751, 0.099520061958437, + 0.199467521245206, 0.495717464058095, 0.675905990683077, + 0.848248235478508, 0.968690546064356, 0.010186928826919, + 0.135440871671036, 0.054423924290583, 0.012868560833637, + 0.067165782413524, 0.014663182224828 / DATA A2 / + 0.333333333333333, 0.166666666666667, 0.333333333333333, + 0.200000000000000, 0.445948490915965, 0.091576213509771, + 0.333333333333333, 0.470142064105115, 0.101286507323456, + 0.249286745170910, 0.063089014491502, 0.310352451033784, + 0.333333333333333, 0.260345966079040, 0.065130102902216, + 0.312865496004874, 0.333333333333333, 0.459292588292723, + 0.170569307751760, 0.050547228317031, 0.263112829634638, + 0.333333333333333, 0.489682519198738, 0.437089591492937, + 0.188203535619033, 0.044729513394453, 0.221962989160766, + 0.333333333333333, 0.485577633383657, 0.109481575485037, + 0.307939838764121, 0.246672560639903, 0.066803251012200, + 0.534611048270758, 0.398969302965855, 0.203309900431282, + 0.119350912282581, 0.032364948111276, 0.356620648261293, + 0.171488980304042, 0.488217389773805, 0.439724392294460, + 0.271210385012116, 0.127576145541586, 0.021317350453210, + 0.275713269685514, 0.281325580989940, 0.116251915907597, + 0.333333333333333, 0.495048184939705, 0.468716635109574, + 0.414521336801277, 0.229399572042831, 0.114424495196330, + 0.024811391363459, 0.268794997058761, 0.291730066734288, + 0.126357385491669, 0.488963910362179, 0.417644719340454, + 0.273477528308839, 0.177205532412543, 0.061799883090873, + 0.019390961248701, 0.172266687821356, 0.336861459796345, + 0.298372882136258, 0.118974497696957, 0.506972916858243, + 0.431406354283023, 0.277693644847144, 0.126464891041254, + 0.070808385974686, 0.018965170241073, 0.261311371140087, + 0.388046767090269, 0.285712220049916, 0.215599664072284, + 0.103575616576386, 0.333333333333333, 0.497380541948438, + 0.413469438549352, 0.470458599066991, 0.240553749969521, + 0.147965794222573, 0.075465187657474, 0.016596402623025, + 0.296555596579887, 0.337723063403079, 0.204748281642812, + 0.189358492130623, 0.085283615682657, 0.333333333333333, + 0.497170540556774, 0.482176322624625, 0.450239969020782, + 0.400266239377397, 0.252141267970953, 0.162047004658461, + 0.075875882260746, 0.015654726967822, 0.334319867363658, + 0.292221537796944, 0.319574885423190, 0.190704224192292, + 0.180483211648746, 0.080711313679564 / DATA A3 / + 0.333333333333333, 0.166666666666667, 0.333333333333333, + 0.200000000000000, 0.445948490915965, 0.091576213509771, + 0.333333333333333, 0.470142064105115, 0.101286507323456, + 0.249286745170910, 0.063089014491502, 0.636502499121399, + 0.333333333333333, 0.260345966079040, 0.065130102902216, + 0.638444188569810, 0.333333333333333, 0.459292588292723, + 0.170569307751760, 0.050547228317031, 0.728492392955404, + 0.333333333333333, 0.489682519198738, 0.437089591492937, + 0.188203535619033, 0.044729513394453, 0.741198598784498, + 0.333333333333333, 0.485577633383657, 0.109481575485037, + 0.550352941820999, 0.728323904597411, 0.923655933587500, + 0.534611048270758, 0.398969302965855, 0.203309900431282, + 0.119350912282581, 0.032364948111276, 0.593201213428213, + 0.807489003159792, 0.488217389773805, 0.439724392294460, + 0.271210385012116, 0.127576145541586, 0.021317350453210, + 0.608943235779788, 0.695836086787803, 0.858014033544073, + 0.333333333333333, 0.495048184939705, 0.468716635109574, + 0.414521336801277, 0.229399572042831, 0.114424495196330, + 0.024811391363459, 0.636351174561660, 0.690169159986905, + 0.851409537834241, 0.488963910362179, 0.417644719340454, + 0.273477528308839, 0.177205532412543, 0.061799883090873, + 0.019390961248701, 0.770608554774996, 0.570222290846683, + 0.686980167808088, 0.879757171370171, 0.506972916858243, + 0.431406354283023, 0.277693644847144, 0.126464891041254, + 0.070808385974686, 0.018965170241073, 0.604954466893291, + 0.575586555512814, 0.724462663076655, 0.747556466051838, + 0.883964574092416, 0.333333333333333, 0.497380541948438, + 0.413469438549352, 0.470458599066991, 0.240553749969521, + 0.147965794222573, 0.075465187657474, 0.016596402623025, + 0.599868711174861, 0.642193524941505, 0.799592720971327, + 0.768699721401368, 0.900399064086661, 0.333333333333333, + 0.497170540556774, 0.482176322624625, 0.450239969020782, + 0.400266239377397, 0.252141267970953, 0.162047004658461, + 0.075875882260746, 0.015654726967822, 0.655493203809423, + 0.572337590532020, 0.626001190286228, 0.796427214974071, + 0.752351005937729, 0.904625504095608 / C CHECK SPACE TYPE OPTIONS IF ( NCORD .LT. 2 .OR. NCORD .GT. 3 ) THEN STOP 'INVALID COORDINATE TYPE, DQRULE' ENDIF C CHECK FOR IDEG OR NQP CONTROL: LDEG = IDEG IF ( NQP .EQ. 0 ) THEN C USE DEGREE CONTROL IF ( IDEG .EQ. 0 ) NQP = 1 IF ( IDEG .LT. 0 .OR. IDEG .GT. MAXDEG ) THEN STOP 'INVALID IDEG ARGUMENT, DQRULE' ELSE NQP = NQPDEG(IDEG) ENDIF ELSE C USE NQP CONTROL LDEG = 0 DO 10 I = 1, MAXDEG IF ( NQP .EQ. NQPDEG(I) ) LDEG = I 10 CONTINUE IF ( LDEG .EQ. 0 ) STOP 'INVALID NQP ARGUMENT, DQRULE' ENDIF C FOUND VALID RULE, NOW EXPAND TABLE TO FULL RULE IPT = ISTART(LDEG) - 1 IRULE = 0 SUM = 0.D0 DO 20 I = 1, LINES(LDEG) J = IPT + I KOUNT = KOUNTS(J) IRULE = IRULE + 1 SUM = SUM + AW(J)*KOUNT WT(IRULE) = AW(J) PT(1,IRULE) = A1(J) PT(2,IRULE) = A2(J) IF ( NCORD .EQ. 3 ) PT(3,IRULE) = A3(J) IF ( KOUNT .GE. 3 ) THEN IRULE = IRULE + 1 WT(IRULE) = AW(J) PT(1,IRULE) = A3(J) PT(2,IRULE) = A1(J) IF ( NCORD .EQ. 3 ) PT(3,IRULE) = A2(J) IRULE = IRULE + 1 WT(IRULE) = AW(J) PT(1,IRULE) = A2(J) PT(2,IRULE) = A3(J) IF ( NCORD .EQ. 3 ) PT(3,IRULE) = A1(J) ENDIF IF ( KOUNT .EQ. 6 ) THEN IRULE = IRULE + 1 WT(IRULE) = AW(J) PT(1,IRULE) = A1(J) PT(2,IRULE) = A3(J) IF ( NCORD .EQ. 3 ) PT(3,IRULE) = A2(J) IRULE = IRULE + 1 WT(IRULE) = AW(J) PT(1,IRULE) = A3(J) PT(2,IRULE) = A2(J) IF ( NCORD .EQ. 3 ) PT(3,IRULE) = A1(J) IRULE = IRULE + 1 WT(IRULE) = AW(J) PT(1,IRULE) = A2(J) PT(2,IRULE) = A1(J) IF ( NCORD .EQ. 3 ) PT(3,IRULE) = A3(J) ENDIF 20 CONTINUE C CHECK VALIDITY OF RESULTS C IF ( SUM .NE. 1.D0 ) WRITE (6,*) C 1 'WARNING, UNITY NOT', SUM,', DQRULE' IF ( NCORD .EQ. 2 ) THEN DO 30 I = 1, NQP WT(I) = WT(I)*0.5D0 30 CONTINUE ENDIF RETURN END SUBROUTINE DSTART (IPRINT, M, NG, NSPACE, NDFREE, 1 INDEX, X, COORD, DD) C * * * * * * * * * * * * * * * * * * * * * * * * * * C INITIALIZE SYSTEM DOF FOR ITERATIVE SOLUTION C * * * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8(A-H,O-Z) PARAMETER ( NPRT = 6 ) DIMENSION DD(NDFREE), X(M,NSPACE), 1 COORD(1,NSPACE), INDEX(NG) C M = NUMBER OF NODES IN SYSTEM C NG = NUMBER OF PARAMETERS (DOF) PER NODE C NSPACE = DIMENSION OF SPACE C NDFREE = TOTAL NUMBER OF SYSTEM DOF C INDEX = SYSTEM DOF NUMBERS FOR DOF AT NODE C X = COORDINATES OF SYSTEM NODES C COORD = SPATIAL COORDINATE ARRAY OF A NODE C DD = SYSTEM ARRAY OF DEGREES OF FREEDOM C IPRINT > 0, PRINT THE STARTING VALUES IF ( IPRINT .GT. 0 ) WRITE (NPRT,5000) 5000 FORMAT ( /, 1 '** STARTING VALUES FOR ITERATIVE SOLUTION **',/, 2 'NODE PARAMETER VALUE') DO 20 I = 1, M C FIND PT COORDS AND DOF NOS CALL INDXPT (I,NG,INDEX) CALL PTCORD (I,M,NSPACE,X,COORD) DO 10 J = 1, NG INDX = INDEX(J) DD(INDX) = START(J,NSPACE,COORD) C START IS A FUNCTION TO DEFINE INITIAL VALUES C OF THE SYSTEM DEGREES OF FREEDOM IF ( IPRINT .GT. 0 ) WRITE (NPRT,5010) I,J,DD(INDX) 5010 FORMAT ( I5, I10, 2X, 1PE13.5 ) 10 CONTINUE 20 CONTINUE RETURN END SUBROUTINE DYNDIM (NUMR, MAXR, NUMI, MAXI, R, RN, I, IN, 1 J, K ) C WARNING: COMPILE WITH EXTRA CONTINUE CARD OPTION -NL40 C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C DYNAMIC DIMENSION CONTROL FOR MODEL C C NOTES: C IF USING FORTRAN 90, THIS CODE IS REALLY NOT NEEDED C SINCE THE "AUTOMATIC ARRAY" FEATURE OF F90 WOULD C LET THE ARRAY SIZES BE DEFINED IN MODEL WHERE THEY C WOULD FIRST APPEAR. IN OTHER WORDS THEY WOULD BE C AUTOMATICALLY "ALLOCATED". THUS, YOU WOULD ONLY C NEED TO "ALLOCATE" THOSE ARRAYS THAT YOU LATER C WANT TO "DEALLOCATE" C C THIS FORTRAN 77 APPROACH TO DYNAMIC DIMENSIONS CALLED C DYNDIM IS ESSENTIALLY WRITTEN BY PROGRAM DIMMAK.F C USING ARRAYS "REALS" AND "INTEGERS", THEN EDITED C TO REMOVE BLANKS, ETC. IT ALSO WRITES MODEL CALL C AND DIMENSION STATEMENTS C C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * PARAMETER ( MAXTYP=3) CHARACTER*8 RN, IN cb DIMENSION TITLE(15), R(MAXR), RN(NUMR), I(MAXI), IN(NUMI), CHARACTER*4 TITLE(15) DIMENSION R(MAXR), RN(NUMR), I(MAXI), IN(NUMI), 1 J(NUMR), K(NUMI) C C THE COMMONS BELOW ARE NOT USED, BUT CAN BE ACTIVATED C BY USERS IF THEY SEE A NEED FOR THEM. NOTE THAT THE C DUPLICATE ARRAY SIZE DATA ARE INCLUDED THERE ALSO. C C COMMON / REAL / R, RN, MMAXR, NNUMR, LLASTR, J C COMMON / INTEGER / MMAXI, NNUMI, LLASTI, IN, K C C I = VECTOR HOLDING ALL INTEGER ARRAYS (APPENDABLE) C IN = NAMES OF EACH INTEGER ARRAY (APPENDABLE) C J = POINTER TO BEGINNING OF EACH REAL ARRAY (APPENDABLE) C K = POINTER TO BEGINNING OF EACH INTEGER ARRAY (APPENDABLE) C LASTI = NUMBER OF THE LAST ASSIGNED INTEGER ARRAY C LASTR = NUMBER OF THE LAST ASSIGNED REAL ARRAY C LLASTI = NUMBER OF THE LAST ASSIGNED INTEGER ARRAY (COMMON) C LLASTR = NUMBER OF THE LAST ASSIGNED REAL ARRAY (COMMON) C MAXI = STORAGE ALLOWED FOR ALL INTEGER ARRAYS C MAXR = STORAGE ALLOWED FOR ALL REAL ARRAYS C MMAXI = STORAGE ALLOWED FOR ALL INTEGER ARRAYS (COMMON) C MMAXR = STORAGE ALLOWED FOR ALL REAL ARRAYS (COMMON) C NNUMI = ALLOWED NUMBER OF INTEGER ARRAYS (VIA COMMON) C NNUMR = ALLOWED NUMBER OF REAL ARRAYS (VIA COMMON) C NUMI = ALLOWED NUMBER OF INTEGER ARRAYS C NUMR = ALLOWED NUMBER OF REAL ARRAYS C R = VECTOR HOLDING ALL REAL ARRAYS (APPENDABLE) C RN = NAMES OF EACH REAL ARRAY (APPENDABLE) C C ** READ APPLICATION CONTROL DATA ** C 1 2 3 4 5 6 712 C23456789012345678901234567890123456789012345678901234567890-----------X CALL CONTROL (TITLE, M, NE, NG, N, NSPACE, NSEG, LBN, NITER, 1 NCURVE, INRHS, ISAY, NNPFIX, NNPFLO, NLPFIX, NLPFLO, 2 MISCFX, MISCFL, NHOMO, LHOMO, NPTWRT, LEMWRT, NTAPE1, 3 NTAPE2, NTAPE3, NTAPE4, NTAPE5, NULCOL, NDFREE, NELFRE, 4 NFLUX, IPTEST, LPTEST, NRB, NQP, LSHAPE, NLTYPE, 5 MODE, IBUG, NBSFIX, NBSFLO, NGF) C C SET ADVANCED USER DEFAULTS NC = N NCOEFF = NDFREE*2 NF = NGF NGEOM = N NPARM = NSPACE NPLT = 0 NTMP = 0 NOMAT = NLTYPE C jea 1/2/96 NSYS = 0 C --- Initialize real pointers --- J(1) = 1 K(1) = 1 c write(6,*) k C --- Calculate real array pointers --- C REAL 1, sys pt coords RN( 1) = 'X ' J( 2) = J( 1) + (M )*(NSPACE )*(1 )+0 C --- Calculate integer array pointers --- C INTEGER 1, all pts bc code IN( 1) = 'IBC ' K( 2) = K( 1) + (M )*(1 )*(1 )+0 C INTEGER 2, codes at a poin IN( 2) = 'KODES ' K( 3) = K( 2) + (NG )*(1 )*(1 )+0 C INTEGER 3, system topology IN( 3) = 'NODES ' K( 4) = K( 3) + (NE )*(N )*(1 )+0 C INTEGER 4, no constrain ty IN( 4) = 'NRES ' K( 5) = K( 4) + (MAXTYP )*(1 )*(1 )+0 C INTEGER 5, el type flag IN( 5) = 'LTYPE ' K( 6) = K( 5) + (NE )*(1 )*(1 )+0 C C INPUT NODES, BC FLAGS, ELEMENTS C C CALL INPUT (M, N, NE, NG, NSPACE, X, IBC, NODES, C LTYPE, NLTYPE) CALL INPUT (M, N, NE, NG, NSPACE, R(J(1)), I(K(1)), I(K(3)), 1 I(K(5)), NLTYPE) C C COUNT BC AND CONSTRAINTS, CONVERT NRES TO NREQ C C CALL CCOUNT (M, NG, NRES, IBC, KODES, MAXACT, NUMCE, C 1 MAXTYP, NREQ ) c fix NREQ below CALL CCOUNT (M, NG, I(K(4)), I(K(1)), I(K(2)), MAXACT, NUMCE, 1 MAXTYP, I(K(4)) ) IF ( IBUG .GT. 0 ) THEN C LIST THE ONLY ARRAYS KNOWN AT THIS POINT LOC1 = 1 LOC2 = 5 CALL LISTI (LOC1, LOC2, NEXTI, IN, K, I) LOC1 = 1 LOC2 = 1 CALL LISTR (LOC1, LOC2, NEXTR, RN, J, R) ENDIF C C --- CALCULATE REAL ARRAY POINTERS --- C C REAL 2, jacobian RN( 2) = 'AJ ' J( 3) = J( 2) + (NSPACE )*(NSPACE )*(1 )+0 C REAL 3, inverse jacobia RN( 3) = 'AJINV ' J( 4) = J( 3) + (NSPACE )*(NSPACE )*(1 )+0 C REAL 4, real pt average RN( 4) = 'AVE ' J( 5) = J( 4) + (M +1 )*(NRB+2 )*(1 )+1 C REAL 5, b matrix RN( 5) = 'B ' J( 6) = J( 5) + (NRB )*(NELFRE )*(1 )+0 C REAL 6, body force RN( 6) = 'BODY ' J( 7) = J( 6) + (NSPACE )*(1 )*(1 )+0 C REAL 7, el load vector RN( 7) = 'C ' J( 8) = J( 7) + (NELFRE )*(1 )*(1 )+0 C REAL 8, sys load vector RN( 8) = 'CC ' J( 9) = J( 8) + (NDFREE )*(1 )*(1 )+0 C REAL 9, constrain coeff RN( 9) = 'CEQ ' J( 10) = J( 9) + (MAXACT )*(NUMCE )*(1 )+0 C REAL 10, el or pt coord RN( 10) = 'COORD ' J( 11) = J( 10) + (N )*(NSPACE )*(1 )+0 C REAL 11, el or pt dof RN( 11) = 'D ' J( 12) = J( 11) + (NELFRE )*(1 )*(1 )+0 C REAL 12, old sys dof RN( 12) = 'DDOLD ' J( 13) = J( 12) + (NDFREE )*(1 )*(1 )+0 IF ( NITER .LT. 2 ) J(13) = J(12) + 1 C REAL 13, global deriv h RN( 13) = 'DGH ' cb J( 14) = J( 13) + (NSPACE )*(N )*(NQP +2 )+1 J( 14) = J( 13) + (NSPACE )*(nelfre )*(NQP +2 )+1 C REAL 14, local deriv g RN( 14) = 'DLG ' J( 15) = J( 14) + (NPARM )*(NGEOM )*(NQP +2 )+1 C REAL 15, local deriv h RN( 15) = 'DLH ' cb J( 16) = J( 15) + (NSPACE )*(N )*(NQP +2 )+1 J( 16) = J( 15) + (NSPACE )*(nelfre )*(NQP +2 )+1 C REAL 16, constitutive ma RN( 16) = 'E ' J( 17) = J( 16) + (NRB )*(NRB )*(1 )+0 C REAL 17, matrix product RN( 17) = 'EB ' J( 18) = J( 17) + (NRB )*(NELFRE )*(1 )+0 C REAL 18, real el propert RN( 18) = 'ELPROP ' J( 19) = J( 18) + (NLPFLO+1 )*(1 )*(1 )+1 C REAL 19, real prop all e RN( 19) = 'FLTEL ' J( 20) = J( 19) + (NE )*(NLPFLO+1 )*(1 )+1 C REAL 20, real prop segme RN( 20) = 'FLTBS ' J( 21) = J( 20) + (NSEG +1 )*(NBSFLO+1 )*(1 )+1 C REAL 21, real misc prop RN( 21) = 'FLTMIS ' J( 22) = J( 21) + (MISCFL+1 )*(1 )*(1 )+1 C REAL 22, real prop all p RN( 22) = 'FLTNP ' J( 23) = J( 22) + (M )*(NNPFLO+1 )*(1 )+1 C REAL 23, flux comps on e RN( 23) = 'FLUX ' J( 24) = J( 23) + (NF +1 )*(1 )*(1 )+1 C REAL 24, all flux on nod RN( 24) = 'FLUXBS ' J( 25) = J( 24) + (NSEG +1 )*(NFLUX +1 )*(1 )+1 C REAL 25, geom interpolat RN( 25) = 'G ' J( 26) = J( 25) + (NGEOM )*(NQP +2 )*(1 )+1 C REAL 26, gauss pts 1-d RN( 26) = 'GPT ' J( 27) = J( 26) + (NQP +1 )*(1 )*(1 )+1 C REAL 27, gauss wts 1-d RN( 27) = 'GWT ' J( 28) = J( 27) + (NQP +1 )*(1 )*(1 )+1 C REAL 28, solution interp RN( 28) = 'H ' cb J( 29) = J( 28) + (N )*(NQP +2 )*(1 )+1 J( 29) = J( 28) + (nelfre )*(NQP +2 )*(1 )+1 C REAL 29, integral of h RN( 29) = 'HINTG ' cb J( 30) = J( 29) + (N )*(NQP+3 )*(1 )+0 J( 30) = J( 29) + (nelfre )*(NQP+3 )*(1 )+0 C REAL 30, plotter data RN( 30) = 'PLTSET ' J( 31) = J( 30) + (NPLT +1 )*(1 )*(1 )+1 C REAL 31, real prop el no RN( 31) = 'PRTLPT ' J( 32) = J( 31) + (N )*(NNPFLO+1 )*(1 )+1 C REAL 32, real mat numb p RN( 32) = 'PRTMAT ' J( 33) = J( 32) + (NLPFLO+1 )*(NOMAT +1 )*(1 )+1 C REAL 33, quadrature coor RN( 33) = 'PT ' J( 34) = J( 33) + (NPARM )*(NQP +1 )*(1 )+0 C REAL 34, dof max min val RN( 34) = 'RANGE ' J( 35) = J( 34) + (NG )*(2 )*(1 )+0 C REAL 35, el or edge sq m RN( 35) = 'S ' J( 36) = J( 35) + (NELFRE )*(NELFRE )*(1 )+0 C REAL 36, stress at el po RN( 36) = 'SATPT ' J( 37) = J( 36) + (NRB+2 )*(N )*(1 )+0 C REAL 37, strain or grad RN( 37) = 'STRAIN ' J( 38) = J( 37) + (NRB+2 )*(1 )*(1 )+0 C REAL 38, initial strain RN( 38) = 'STRAN0 ' J( 39) = J( 38) + (NRB )*(1 )*(1 )+0 C REAL 39, stress + rms or RN( 39) = 'STRESS ' J( 40) = J( 39) + (NRB+2 )*(1 )*(1 )+0 C REAL 40, sys control dat RN( 40) = 'SYSDAT ' J( 41) = J( 40) + (NSYS +1 )*(1 )*(1 )+1 C REAL 41, temporary work RN( 41) = 'TMP ' J( 42) = J( 41) + (NTMP +1 )*(1 )*(1 )+1 C REAL 42, values at corne RN( 42) = 'VALC ' J( 43) = J( 42) + (NRB )*(NC +1 )*(1 )+1 C REAL 43, values on edge RN( 43) = 'VALE ' J( 44) = J( 43) + (NRB )*(NC +1 )*(1 )+1 C REAL 44, quadrature weig RN( 44) = 'WT ' J( 45) = J( 44) + (NQP +1 )*(1 )*(1 )+0 C REAL 45, xy ends of a li RN( 45) = 'XPT ' J( 46) = J( 45) + (NSPACE )*(2 )*(1 )+0 C REAL 46, global of gauss RN( 46) = 'XYZ ' J( 47) = J( 46) + (NSPACE )*(1 )*(1 )+0 C REAL 47, sys answers RN( 47) = 'DD ' J( 48) = J( 47) + (NDFREE )*(1 )*(1 )+0 C REAL 48, elem post process RN( 48) = 'USEREL ' J( 49) = J( 48) + (NG )*(N )*(1 )+0 C REAL 49, pt post process RN( 49) = 'USERPT ' J( 50) = J( 49) + (NG )*(1 )*(1 )+0 C REAL 50, sys square matr RN( 50) = 'SS ' J( 51) = J( 50) + (NCOEFF )*(1 )*(1 )+0 LASTR = J(51) NEXTR = 51 IF ( NEXTR .GT. NUMR ) THEN WRITE (6,*) 'IN DRIVER, SET NUMR > ', NEXTR STOP 'IN DRIVER, INCREASE NUMR' ENDIF C C --- CALCULATE INTEGER ARRAY POINTERS --- C C INTEGER 6, pt ave counter IN( 6) = 'IADD ' K( 7) = K( 6) + (M +1 )*(1 )*(1 )+1 C INTEGER 7, skyline diagona IN( 7) = 'IDIAG ' K( 8) = K( 7) + (NDFREE )*(1 )*(1 )+0 C INTEGER 8, dof index pt or IN( 8) = 'INDEX ' K( 9) = K( 8) + (NELFRE )*(1 )*(1 )+0 C INTEGER 9, el where pt is IN( 9) = 'LFIRST ' K( 10) = K( 9) + (M )*(1 )*(1 )+0 C INTEGER 10, el where pt is IN( 10) = 'LLAST ' K( 11) = K( 10) + (M )*(1 )*(1 )+0 C INTEGER 11, el or edge topo IN( 11) = 'LNODE ' K( 12) = K( 11) + (N )*(1 )*(1 )+0 C INTEGER 12, integer prop al IN( 12) = 'LPFIX ' K( 13) = K( 12) + (NE )*(NLPFIX+1 )*(1 )+1 C INTEGER 13, fixed prop segm IN( 13) = 'NBSPFX ' K( 14) = K( 13) + (NSEG +1 )*(NBSFIX+1 )*(1 )+1 C INTEGER 14, pts of el fix p IN( 14) = 'LPPROP ' K( 15) = K( 14) + (NNPFIX+1 )*(1 )*(1 )+1 C INTEGER 15, el integer prop IN( 15) = 'LPROP ' K( 16) = K( 15) + (NLPFIX+1 )*(1 )*(1 )+1 C INTEGER 16, data for el typ IN( 16) = 'LTDATA ' K( 17) = K( 16) + (6 )*(NLTYPE )*(1 )+0 C INTEGER 17, integer misc pr IN( 17) = 'MISFIX ' K( 18) = K( 17) + (MISCFX+1 )*(1 )*(1 )+1 C INTEGER 18, constraint inde IN( 18) = 'NDXC ' K( 19) = K( 18) + (MAXACT )*(NUMCE )*(1 )+0 C INTEGER 19, all nodes w flu IN( 19) = 'NODEF ' K( 20) = K( 19) + (NSEG +1 )*(LBN +1 )*(1 )+1 C INTEGER 20, nodes of max mi IN( 20) = 'NRANGE ' K( 21) = K( 20) + (NG )*(2 )*(1 )+0 C INTEGER 21, no constrain ty IN( 21) = 'NREQ ' K( 22) = K( 21) + (MAXTYP )*(1 )*(1 )+0 c fix from ccount, on next dimmak run move NREQ after NRES do 123 ijk = 1,maxtyp i(k(21)+ijk-1) = i(k(4)+ijk-1) 123 continue C INTEGER 22, sys pts fix pro IN( 22) = 'NPFIX ' K( 23) = K( 22) + (M )*(NNPFIX+1 )*(1 )+1 C INTEGER 23, el col heights IN( 23) = 'LHIGH ' K( 24) = K( 23) + (NELFRE )*(1 )*(1 )+0 LASTI = K(24) NEXTI = 24 IF ( NEXTI .GT. NUMI ) THEN WRITE (6,*) 'IN DRIVER, SET NUMI > ', NEXTI STOP 'IN DRIVER, INCREASE NUMI' ENDIF IF ( IBUG .GT. 0 ) THEN C PRINT THE ARRAYS KNOWN AT THIS POINT LOC1 = 1 LOC2 = 5 CALL LISTI (LOC1, LOC2, NEXTI, IN, K, I) LOC1 = 1 LOC2 = 1 CALL LISTR (LOC1, LOC2, NEXTR, RN, J, R) ENDIF C -------------------------- C --- Call the real main program --- C -------------------------- C C CALL MODEL96 (MAXR, MAXI, NUMR, NUMI, LASTR, LASTI, NEXTR, C 1 NEXTI, R, RN, I, IN, J, K, C 2 TITLE, NSEG, LBN, NITER, NCURVE, INRHS, ISAY, C 3 NNPFIX, NLPFIX, MISCFX, MISCFL, NHOMO, LHOMO, NPTWRT, C 4 LEMWRT, C, NTAPE2, NTAPE3, NTAPE4, NTAPE5, NULCOL, C 5 MAXTYP, NLTYPE, NUMCE, IPTEST, LPTEST, MODE, M, C 6 MAXACT, N, NC, NCOEFF, NDFREE, NE, NELFRE, C 7 NGF, NFLUX, NG, NGEOM, NLPFLO, NNPFLO, NOMAT, C 8 NPARM, NPLT, NQP, NRB, NSPACE, NSYS, NTMP, C 9 LSHAPE, IBUG, NBSFIX, NBSFLO, C 2 X, AJ, AJINV, AVE, B, C 3 BODY, NTAPE1, CC, CEQ, COORD, C 4 D, DDOLD, DGH, DLG, DLH, C 5 E, EB, ELPROP, FLTEL, FLTBS, C 6 FLTMIS, FLTNP, FLUX, FLUXBS, G, C 7 GPT, GWT, H, HINTG, PLTSET, C 8 PRTLPT, PRTMAT, PT, RANGE, S, C 9 SATPT, STRAIN, STRAN0, STRESS, SYSDAT, C 1 TMP, VALC, VALE, WT, XPT, C 2 XYZ, DD, USEREL, USERPT, SS, C 3 IBC, KODES, NODES, NRES, LTYPE, C 4 IADD, IDIAG, INDEX, LFIRST, LLAST, C 5 LNODE, LPFIX, NBSPFX, LPPROP, LPROP, C 6 LTDATA, MISFIX, NDXC, NODEF, NRANGE, C 7 NREQ, NPFIX, LHIGH ) C CALL MODEL96 (MAXR, MAXI, NUMR, NUMI, LASTR, LASTI, NEXTR, 1 NEXTI,R,RN,I,IN,J,K,TITLE,NSEG,LBN,NITER,NCURVE,INRHS,ISAY, 2 NNPFIX,NLPFIX,MISCFX,MISCFL,NHOMO,LHOMO,NPTWRT,LEMWRT,NTAPE1, 3 NTAPE2,NTAPE3,NTAPE4,NTAPE5,NULCOL,MAXTYP,NLTYPE,NUMCE,IPTEST, 4 LPTEST,MODE,M,MAXACT,N,NC,NCOEFF,NDFREE,NE,NELFRE,NGF,NFLUX,NG, 5 NGEOM,NLPFLO,NNPFLO,NOMAT,NPARM,NPLT,NQP,NRB,NSPACE,NSYS,NTMP, 6 LSHAPE,IBUG,NBSFIX,NBSFLO,R(J(1)),R(J(2)),R(J(3)),R(J(4)), 7 R(J(5)),R(J(6)),R(J(7)),R(J(8)),R(J(9)),R(J(10)),R(J(11)), 8 R(J(12)),R(J(13)),R(J(14)),R(J(15)),R(J(16)),R(J(17)),R(J(18)), 9 R(J(19)),R(J(20)),R(J(21)),R(J(22)),R(J(23)),R(J(24)),R(J(25)), 1 R(J(26)),R(J(27)),R(J(28)),R(J(29)),R(J(30)),R(J(31)),R(J(32)), 2 R(J(33)),R(J(34)),R(J(35)),R(J(36)),R(J(37)),R(J(38)),R(J(39)), 3 R(J(40)),R(J(41)),R(J(42)),R(J(43)),R(J(44)),R(J(45)),R(J(46)), 4 R(J(47)),R(J(48)),R(J(49)),R(J(50)),I(K(1)),I(K(2)),I(K(3)), 5 I(K(4)),I(K(5)),I(K(6)),I(K(7)),I(K(8)),I(K(9)),I(K(10)), 6 I(K(11)),I(K(12)),I(K(13)),I(K(14)),I(K(15)),I(K(16)),I(K(17)), 7 I(K(18)),I(K(19)),I(K(20)),I(K(21)),I(K(22)),I(K(23))) RETURN END SUBROUTINE ELBAND (N, NG, IBW, LNODE) C * * * * * * * * * * * * * * * * * * * * * * * * * C ELEMENT BANDWIDTH CALCULATION C * * * * * * * * * * * * * * * * * * * * * * * * * DIMENSION LNODE(N) C LNODE = ELEMENT INCIDENCES C N = NUMBER OF NODES PER ELEMENT C NG = NUMBER OF PARAMETERS PER NODE C IBW = UPPER HALF BANDWIDTH, INCLUDING DIAGONAL IBW = 1 NLESS = N - 1 DO 20 I = 1, NLESS II = I + 1 LNI = LNODE(I) C ALLOW FOR OMITTED NODES IF ( LNI .GT. 0 ) THEN DO 10 J = II, N LNJ = LNODE(J) IF ( LNJ .GT. 0 ) THEN NEW = NG*( IABS( LNJ-LNI ) + 1) IF ( NEW .GT. IBW ) IBW = NEW ENDIF 10 CONTINUE ENDIF 20 CONTINUE RETURN END SUBROUTINE ELCOL (N, NSPACE, NELFRE, NRB, NQP, NGEOM, 1 NPARM, NNPFIX, NNPFLO, MISCFX, MISCFL, NLPFIX, 2 NLPFLO, COORD, C, H, DGH, B, E, EB, STRAIN, 3 STRAN0, STRESS, BODY, PT, WT, XYZ, DLH, G, DLG, 4 AJ, AJINV, HINTG, D, PRTLPT, FLTMIS, ELPROP, 5 PRTMAT, MISFIX, LSHAPE, LPROP, LPPROP, NTAPE1, NTAPE2, 6 NTAPE3, NTAPE4, NTAPE5, LNODE, NG) C * * * * * * * * * * * * * * * * * * * * * * * * * * * * C GENERATE ELEMENT COLUMN MATRIX C * * * * * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8 (A-H,O-Z) C ALWAYS USED DIMENSION COORD(N,NSPACE), C(NELFRE) C USUALLY USED cb DIMENSION H(N), DGH(NSPACE,N), B(NRB,NELFRE), DIMENSION H(nelfre), DGH(NSPACE,nelfre), B(NRB,NELFRE), 1 E(NRB,NRB), EB(NRB,NELFRE), STRAIN(NRB+2), 2 STRAN0(NRB), STRESS(NRB+2), BODY(NSPACE) C OPTIONAL FOR NUMERICAL INTEGRATION cb DIMENSION PT(NPARM,NQP), WT(NQP), XYZ(3), DLH(NSPACE,N), cb 2 AJINV(NSPACE,NSPACE), HINTG(N), LNODE(N) DIMENSION PT(NPARM,NQP), WT(NQP), XYZ(3), DLH(NSPACE,nelfre), 1 G(NGEOM), DLG(NPARM,NGEOM), AJ(NSPACE,NSPACE), 2 AJINV(NSPACE,NSPACE), HINTG(nelfre), LNODE(N) C OPTIONAL PROPERTY AND SOLUTION VALUES DIMENSION D(NELFRE), PRTLPT(N,0:NNPFLO), FLTMIS(0:MISCFL), 1 ELPROP(0:NLPFLO), 2 PRTMAT(0:NLPFLO), MISFIX(0:MISCFX), 3 LPROP(0:NLPFIX), 4 LPPROP(0:NNPFIX) C VARIABLES: C AJ = JACOBIAN C AJINV = JACOBIAN INVERSE C B = STRAIN-DISPLACEMENT (GRADIENT) MATRIX C BODY = BODY FORCE VECTOR C COORD = SPATIAL COORDINATES OF ELEMENT'S NODES C D = NODAL PARAMETERS ASSOCIATED WITH AN ELEMENT C DGH = GLOBAL DERIVATIVES INTERPOLATION FUNCTIONS C DLG = LOCAL DERIVATIVES GEOMETRIC INTERPOLATION C DLH = LOCAL DERIVATIVES INTERPOLATION FUNCTIONS C E = CONSTITUTIVE MATRIX C EB = PRODUCT OF E*B C ELPROP = ELEMENT ARRAY OF FLOATING PT PROPERTIES C FLTMIS = SYSTEM STORAGE OF FLOATING PT MISC PROP C G = GEOMETRIC INTERPOLATION FUNCTIONS C H = SOLUTION INTERPOLATION FUNCTIONS C HINTG = INTEGRAL OF INTERPOLATION FUNCTIONS C LPPROP = INTEGER PROPERTIES AT EACH ELEMENT NODE C LPROP = ARRAY INTEGER POINT ELEMENT PROPERTIES C MISFIX = MISCELLANEOUS INTEGER SYSTEM PROPERTIES C N = NUMBER OF NODES PER ELEMENT C NELFRE = NUMBER OF DEGREES OF FREEDOM PER ELEMENT C NGEOM = NUMBER OF GEOMETRY NODES C NMAT = NUMBER OF MATERIAL TYPES C NPARM = DIMENSION OF PARAMWETRIC SPACE C NQP = NUMBER OF QUADRATURE POINTS C NRB = NUMBER OF ROWS IN B AND E MATRICES C NSPACE = DIMENSION OF SPACE C NTAPE1 = UNIT FOR POST SOLUTION MATRICES STORAGE C NTAPE2,3,4 = OPTIONAL UNITS FOR USER (USED WHEN > 0) C PRTLPT = REAL PROPERTIES AT ELEMENT NODES C PRTMAT = REAL ELEM PROPERTIES BASED ON MATERIAL NUMBER C PT = QUADRATURE COORDINATES C S = ELEMENT SQUARE MATRIX C STRAIN = STRAIN OR GRADIENT VECTOR C STRAN0 = INITIAL STRAIN OR GRADIENT VECTOR C STRESS = STRESS VECTOR C WT = QUADRATURE WEIGHTS C XYZ = SPACE COORDINATES AT A POINT C ..................................................... C *** ELCOL PROBLEM DEPENDENT STATEMENTS FOLLOW *** C ..................................................... RETURN END SUBROUTINE ELCORD (M,N,NSPACE,X,COORD,LNODE) C * * * * * * * * * * * * * * * * * * * * * * * * * * C DETERMINE COORDINATES OF NODES ON ELEMENT C * * * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8(A-H,O-Z) DIMENSION X(M,NSPACE), COORD(N,NSPACE), LNODE(N) C M = NUMBER OF NODES IN SYSTEM C NSPACE = DIMENSION OF SPACE C N = NUMBER OF NODES PER ELEMENT C X = COORDINATES OF SYSTEM NODES C COORD = COORDINATES OF ELEMENT NODES C LNODE = N ELEMENT INCIDENCES OF ELEMENT DO 20 K = 1, NSPACE DO 10 I = 1, N C ALLOW FOR OMITTED NODES IF ( LNODE(I) .GT. 0 ) 1 COORD(I,K) = X(LNODE(I),K) 10 CONTINUE 20 CONTINUE RETURN END SUBROUTINE ELFRE (NDFREE, NELFRE, D, DD, INDEX) C * * * * * * * * * * * * * * * * * * * * * * * * * * C EXTRACT ELEMENT DEGREES OF FREEDOM FROM SYSTEM DOF C * * * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8 (A-H,O-Z) DIMENSION D(NELFRE), DD(NDFREE), INDEX(NELFRE) C D = NODAL PARAMETERS ASSOCIATED C DD = SYSTEM ARRAY OF NODAL PARAMETERS C INDEX = ARRAY OF SYSTEM DEGREE OF FREEDOM NUMBERS C NELFRE = NUMBER OF DEGREES OF FREEDOM PER ELEMENT C NDFREE = TOTAL NUMBER OF SYSTEM DEGREES OF FREEDOM DO 10 I = 1, NELFRE C ALLOW FOR OMITTED NODES IF ( INDEX(I) .GT. 0 ) THEN D(I) = DD(INDEX(I)) ELSE D(I) = 0.0 ENDIF 10 CONTINUE RETURN END SUBROUTINE ELHIGH (NELFRE,INDEX,LHIGH) C * * * * * * * * * * * * * * * * * * * * * * * * C FIND SYSTEM COLUMN HEIGHTS OF AN ELEMENT C * * * * * * * * * * * * * * * * * * * * * * * * DIMENSION INDEX(NELFRE), LHIGH(NELFRE) C NELFRE = NO OF DEGREES OF FREEDOM OF ELEMENT C INDEX = SYSTEM DOF NOS OF ELEMENT PARAMETERS C LHIGH(I) = COLUMN HEIGHT FOR EQUATION INDEX(I) MIN = INDEX(1) C FIND MINIMUM INDEX DO 10 I = 1, NELFRE LHIGH(I) = 0 NDX = INDEX(I) C ALLOW FOR OMITTED NODES IF ( NDX .GT. 0 .AND. NDX .LT. MIN ) MIN = NDX 10 CONTINUE C CONVERT TO COLUMN HEIGHTS MIN = MIN - 1 DO 20 I = 1, NELFRE NDX = INDEX(I) IF ( NDX .GT. 0 ) LHIGH(I) = NDX - MIN 20 CONTINUE RETURN END SUBROUTINE ELPOST (N, NSPACE, NELFRE, NRB, NQP, NNPFIX, 1 NNPFLO, MISCFX, MISCFL, NLPFIX, NLPFLO, H, 2 DGH, B, E, EB, STRAIN, STRAN0, STRESS, BODY, 3 HINTG, D, PRTLPT, FLTMIS, ELPROP, 4 PRTMAT, MISFIX, LSHAPE, LPROP, LPPROP, NTAPE1, 5 NTAPE2, NTAPE3, NTAPE4, NTAPE5, LNODE, NG ) C * * * * * * * * * * * * * * * * * * * * * * * * * * * * C GENERATE OR STORE DATA FOR ELEMENT POST-SOLUTION USE C * * * * * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8 (A-H,O-Z) C USUALLY USED cb DIMENSION H(N), DGH(NSPACE,N), B(NRB,NELFRE), HINTG(N), DIMENSION H(nelfre), DGH(NSPACE,nelfre), B(NRB,NELFRE), 1 HINTG(nelfre), 1 E(NRB,NRB), EB(NRB,NELFRE), STRAIN(NRB+2), 2 STRAN0(NRB), STRESS(NRB+2), BODY(NSPACE), LNODE(N) C OPTIONAL PROPERTY AND SOLUTION VALUES DIMENSION D(NELFRE), PRTLPT(N,0:NNPFLO), FLTMIS(0:MISCFL), 1 ELPROP(0:NLPFLO), 2 PRTMAT(0:NLPFLO), MISFIX(0:MISCFX), 3 LPROP(0:NLPFIX), 4 LPPROP(0:NNPFIX) C VARIABLES: C B = STRAIN-DISPLACEMENT (GRADIENT) MATRIX C BODY = BODY FORCE VECTOR C D = NODAL PARAMETERS ASSOCIATED WITH AN ELEMENT C DGH = GLOBAL DERIVATIVES INTERPOLATION FUNCTIONS C E = CONSTITUTIVE MATRIX C EB = PRODUCT OF E*B C ELPROP = ELEMENT ARRAY OF FLOATING PT PROPERTIES C FLTMIS = SYSTEM STORAGE OF FLOATING PT MISC PROP C H = SOLUTION INTERPOLATION FUNCTIONS C HINTG = INTEGRAL OF INTERPOLATION FUNCTIONS C LPPROP = INTEGER PROPERTIES AT EACH ELEMENT NODE C LPROP = ARRAY INTEGER POINT ELEMENT PROPERTIES C MISFIX = MISCELLANEOUS INTEGER SYSTEM PROPERTIES C N = NUMBER OF NODES PER ELEMENT C NELFRE = NUMBER OF DEGREES OF FREEDOM PER ELEMENT C NGEOM = NUMBER OF GEOMETRY NODES C NMAT = NUMBER OF MATERIAL TYPES C NPARM = DIMENSION OF PARAMWETRIC SPACE C NQP = NUMBER OF QUADRATURE POINTS C NRB = NUMBER OF ROWS IN B AND E MATRICES C NSPACE = DIMENSION OF SPACE C NTAPE1 = UNIT FOR POST SOLUTION MATRICES STORAGE C NTAPE2,3,4 = OPTIONAL UNITS FOR USER (USED WHEN > 0) C PRTLPT = REAL PROPERTIES AT ELEMENT NODES C PRTMAT = REAL ELEM PROPERTIES BASED ON MATERIAL NUMBER C STRAIN = STRAIN OR GRADIENT VECTOR C STRAN0 = INITIAL STRAIN OR GRADIENT VECTOR C STRESS = STRESS VECTOR C ..................................................... C *** ELPOST PROBLEM DEPENDENT STATEMENTS FOLLOW *** C ..................................................... RETURN END SUBROUTINE ELPRTY (LID, LHOMO, NE, NLPFIX, NLPFLO, 1 LPFIX, FLTEL, LPROP, ELPROP) C * * * * * * * * * * * * * * * * * * * * * * * * * * C EXTRACT PROPERTIES OF A ELEMENT, LID, C FROM TOTAL PROPERTIES ARRAYS C * * * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8(A-H,O-Z) DIMENSION FLTEL(NE,0:NLPFLO), ELPROP(0:NLPFLO), 1 LPFIX(NE,0:NLPFIX), LPROP(0:NLPFIX) C LPFIX = SYSTEM ARRAY OF FIXED PT ELEM PROPERTIES C LPROP = ELEM FIXED PT PROPERTIES ARRAY C FLTEL = SYS ARRAY OF FLOATING PT NODAL PROP C ELPROP = ELEM FLOATING PT PROPERTIES ARRAY C LHOMO = 1, IF PROPERTIES ARE SAME IN ALL ELEMENTS C NLPFIX = NUMBER OF INTEGER ELEMENT PROPERTIES C NLPFLO = NUMBER OF REAL ELEMENT PROPERTIES IF ( LHOMO .EQ. 1 ) THEN I = 1 ELSE I = LID ENDIF C FLOATING POINT PROPERTIES DO 10 J = 1, NLPFLO 10 ELPROP(J) = FLTEL(I,J) C FIXED POINT PROPERTIES DO 20 J = 1, NLPFIX 20 LPROP(J) = LPFIX(I,J) RETURN END SUBROUTINE ELREACT (NELFRE, NTAPE2, S, C, IOPT) C * * * * * * * * * * * * * * * * * * * * * * * * * * * C SAVE ELEMENT MATRICES FOR REACTEL TO LATER C GET REACTIONS (FLUXES) AT AN ELEMENTS NODES C * * * * * * * * * * * * * * * * * * * * * * * * * * * DIMENSION S(NELFRE,NELFRE), C(NELFRE) C C = ELEMENT COLUMN MATRIX C IOPT = WRITE OPTION CODE 1-ONCE, 2-TWICE C NELFRE = NUMBER OF ELEMENT DOF, NG*N C NTAPE2 = UNIT TO HOLDING S & C FROM ELEMENT IE C S = ELEMENT SQUARE MATRIX IF ( NTAPE2 .LE. 0 ) PRINT *, 'WARNING, ELREACT SKIPPED.' C STORE STIFFNESS, AND SOURCE FOR ELEM REACTIONS C SINGLE WRITE IF ( IOPT .EQ. 1 ) THEN WRITE (NTAPE2) S, C C DOUBLE WRITE ELSE IF ( IOPT .EQ. 2 ) THEN WRITE (NTAPE2) S WRITE (NTAPE2) C ENDIF RETURN END SUBROUTINE ELSQ (N, NSPACE, NELFRE, NRB, NQP, NGEOM, 1 NPARM, NNPFIX, NNPFLO, MISCFX, MISCFL, NLPFIX, 2 NLPFLO, COORD, S, C, H, DGH, B, E, EB, STRAIN, 3 STRAN0, STRESS, BODY, PT, WT, XYZ, DLH, G, DLG, 4 AJ, AJINV, HINTG, D, PRTLPT, FLTMIS, ELPROP, 5 PRTMAT, MISFIX, LSHAPE, LPROP, LPPROP, NTAPE1, NTAPE2, 6 NTAPE3, NTAPE4, NTAPE5, LNODE, NG, IE ) C * * * * * * * * * * * * * * * * * * * * * * * * * * * * C GENERATE ELEMENT SQUARE MATRIX, OPTIONAL COLUMN MATRIX C * * * * * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8 (A-H,O-Z) C ALWAYS USED DIMENSION COORD(N,NSPACE), S(NELFRE,NELFRE) C USUALLY USED cb DIMENSION C(NELFRE), H(N), DGH(NSPACE,N), B(NRB,NELFRE), DIMENSION C(NELFRE), H(nelfre), DGH(NSPACE,nelfre), 1 B(NRB,NELFRE), 1 E(NRB,NRB), EB(NRB,NELFRE), STRAIN(NRB+2), 2 STRAN0(NRB), STRESS(NRB+2), BODY(NSPACE) C OPTIONAL FOR NUMERICAL INTEGRATION cb DIMENSION PT(NPARM,0:NQP), WT(0:NQP), DLH(NSPACE,N), cb 2 AJINV(NSPACE,NSPACE), HINTG(N), LNODE(N), DIMENSION PT(NPARM,0:NQP), WT(0:NQP), DLH(NSPACE,nelfre), 1 G(NGEOM), DLG(NPARM,NGEOM), AJ(NSPACE,NSPACE), 2 AJINV(NSPACE,NSPACE), HINTG(nelfre), LNODE(N), 3 XYZ(NSPACE) C OPTIONAL PROPERTY AND SOLUTION VALUES DIMENSION D(NELFRE), PRTLPT(N,0:NNPFLO), FLTMIS(0:MISCFL), 1 ELPROP(0:NLPFLO), 2 PRTMAT(0:NLPFLO), MISFIX(0:MISCFX), 3 LPROP(0:NLPFIX), 4 LPPROP(0:NNPFIX) C VARIABLES: C AJ = JACOBIAN C AJINV = JACOBIAN INVERSE C B = STRAIN-DISPLACEMENT (GRADIENT) MATRIX C BODY = BODY FORCE VECTOR C COORD = SPATIAL COORDINATES OF ELEMENT'S NODES C D = NODAL PARAMETERS ASSOCIATED WITH AN ELEMENT C DGH = GLOBAL DERIVATIVES INTERPOLATION FUNCTIONS C DLG = LOCAL DERIVATIVES GEOMETRIC INTERPOLATION C DLH = LOCAL DERIVATIVES INTERPOLATION FUNCTIONS C E = CONSTITUTIVE MATRIX C EB = PRODUCT OF E*B C ELPROP = ELEMENT ARRAY OF FLOATING PT PROPERTIES C FLTMIS = SYSTEM STORAGE OF FLOATING PT MISC PROP C G = GEOMETRIC INTERPOLATION FUNCTIONS C H = SOLUTION INTERPOLATION FUNCTIONS C HINTG = INTEGRAL OF INTERPOLATION FUNCTIONS C LPPROP = INTEGER PROPERTIES AT EACH ELEMENT NODE C LPROP = ARRAY INTEGER POINT ELEMENT PROPERTIES C MISFIX = MISCELLANEOUS INTEGER SYSTEM PROPERTIES C N = NUMBER OF NODES PER ELEMENT C NELFRE = NUMBER OF DEGREES OF FREEDOM PER ELEMENT C NGEOM = NUMBER OF GEOMETRY NODES C NMAT = NUMBER OF MATERIAL TYPES C NPARM = DIMENSION OF PARAMWETRIC SPACE C NQP = NUMBER OF QUADRATURE POINTS C NRB = NUMBER OF ROWS IN B AND E MATRICES C NSPACE = DIMENSION OF SPACE C NTAPE1 = UNIT FOR POST SOLUTION MATRICES STORAGE C NTAPE2,3,4 = OPTIONAL UNITS FOR USER (USED WHEN > 0) C PRTLPT = REAL PROPERTIES AT ELEMENT NODES C PRTMAT = REAL ELEM PROPERTIES BASED ON MATERIAL NUMBER C PT = QUADRATURE COORDINATES C S = ELEMENT SQUARE MATRIX C STRAIN = STRAIN OR GRADIENT VECTOR C STRAN0 = INITIAL STRAIN OR GRADIENT VECTOR C STRESS = STRESS VECTOR C WT = QUADRATURE WEIGHTS C XYZ = SPACE COORDINATES AT A POINT C ..................................................... C *** ELSQ PROBLEM DEPENDENT STATEMENTS FOLLOW *** C ..................................................... C APPLICATION MWR FOR ODE C ODE U,XX + X^L = 0, U(0)=0=U(1) C NG = 1, N = 2, MISCFX = 1 C QUADRATIC STIFFNESS 1-----2 (-1,1) X1 = COORD(1,1) X2 = COORD(2,1) DL = X2 - X1 if ( dl .le. 0. ) print *, 'invalid length, elsq' C NUMERICALLY INTEGRATED STIFFNESS & SOURCE VECTOR L = MISFIX(1) DXDR = DL/2. CALL ZEROA (NELFRE,C) CALL ZEROA (NELFRE*NELFRE,S) NEED = (2 + L)/2 IF ( NQP .LT. NEED ) WRITE (6,*) 'WARNING: NQP TOO LOW' DO 10 IQ = 1,NQP C GET INTERPOLATION FUNCTIONS, AND X-COORD CALL SHP2L (PT(1,IQ), H) XIQ = DOT (N, H, COORD) C GLOBAL DERIVATIVE CALL DER2L (PT(1,IQ), DLH) DO 30 J = 1, N DGH(1,J) = DLH(1,J)/DXDR 30 CONTINUE DO 20 J = 1, N C SOURCE VECTOR C(J) = C(J) + H(J) * XIQ**L * WT(IQ) * DXDR C SQUARE MATRIX DO 40 K = 1, N 40 S(K,J) = S(K,J) + DGH(1,K)*DGH(1,J) * WT(IQ) * DXDR 20 CONTINUE C STORE GRADIENT DATA HERE INSTEAD OF IN ELPOST WRITE (NTAPE1) DGH 10 CONTINUE RETURN END SUBROUTINE ERROR (NE, N, NG, NELFRE, NDFREE, NODES, LNODE, INDEX, 1 DD, D, M, AVE, NS, NM, NQ, H, X, NSPACE, ELAVE, 2 B, EHAT, ESTAR, EEL, ENORM, GNORM, IADD, ERRAVE, 3 SYSNOR, NTAPE ) C ------------------------------------------------------------------ C ELEMENT ERROR ESTIMATES FOR ADAPTIVE SOLUTIONS C ------------------------------------------------------------------ cb DIMENSION DD(NDFREE), D(NELFRE), NODES(NE,N), AVE(M,NS+2), H(N) DIMENSION DD(NDFREE), D(NELFRE), NODES(NE,N), AVE(M,NS+2), 1 H(nelfre) DIMENSION ELAVE (N,NS+2), B(NS,NELFRE), EHAT(NS), ESTAR(NS+2) DIMENSION EEL(NS+2), ENORM(NE), X(M,NSPACE), LNODE(N) DIMENSION INDEX(NELFRE) C THE FOLLOWING DIMENSIONS ARE FOR MOVIE.BYU SUBROUTINE DIMENSION IADD(M), ERRAVE(M) C.... METHOD: ERROR ESTIMATE BY USING THE NORM OF DIFFERENCE C.... BETWEEN THE ELEMENT GRADIENT AND ITS NODAL AVERAGE GRADIENT. C.... FOR STRESS ANALYSIS, GRADIENT MEANS STRESS "VECTOR". C --- ARRAYS --- C AVE = NODAL AVERAGED GRADIENT "VECTORS" C B = B MATRIX IN STIFFNESS INTEGRAL C EEL = VECTOR OF THE DIFFERENCE BETWEEN ESTAR AND EHAT C EHAT = ARRAY CONTAINING THE VALUES OF THE DISCONTINUOUS C GRADIENTS AT THE QUADRATURE POINTS. C ELAVE = MATRIX CONTAINING THE VALUES OF THE NODAL C AVERAGE GRADIENTS FOR AN ELEMENT. C ENORM = THE ERROR L2 NORM FOR THE ELEMENT (RELATIVE) C ERRAVE= AVERAGE ERROR AT A NODE C ESTAR = ARRAY CONTAINING THE VALUES OF THE NODAL AVERAGE C GRADIENT AT THE QUADRATURE POINTS C GNORM = GLOBAL NORM C H = ARRAY CONTAINING THE VALUES OF THE SHAPE FUNCTIONS C AT A QUADRATURE POINT C IADD = NUMBER OF ELEMENTS CONNECTED TO A NODE C NS = NUMBER OF STRAINS ( ROWS IN B , AND D ) C SYSNOR= SYSTEM NORM. THE GRADIENT L2 NORM AS A ROOT MEAN C SQUARE OF ALL ELEMENTS C C.... INITIALIZING SYSNOR = 0.0 C.... REWIND THE FILE WITH THE DATA REWIND NTAPE C.... LOOP OVER ELEMENTS TO FIND THE ERROR DO 50 IE = 1, NE C.... EXTRACT D(NELFRE) ('PHI') AND ELAVE(N,NS) FOR THE ELEMENT C.... FIND THE DEGREES OF FREEDOM FOR THIS ELEMENT CALL LNODES (IE, NE, N, NODES, LNODE) CALL INDXEL (N, NELFRE, NG, LNODE, INDEX) CALL ELFRE (NDFREE, NELFRE, D, DD, INDEX) C.... GET CONTRIBUTIONS FROM EACH COMPONENT OF THE GRADIENT 'AVE' DO 60 J = 1, NS CALL ELFRE (M, N, ELAVE(1,J), AVE(1,J), LNODE) 60 CONTINUE C.... LOOP OVER QUADRATURE POINTS FOR CURRENT ELEMENT ENORM(IE) = 0.0 GNORM = 0.0 C.... READ THE NUMBER OF POINTS (WRITTEN IN ISOPAR.F) READ (NTAPE,*) NIP DO 70 IP = 1, NIP C.... READ THE REQUIRED DATA :H,B,DETWT (WRITTEN IN ISOPAR.F) READ (NTAPE,1000) ( H(I),I=1,N) 1000 FORMAT ( 6( 1X, 1PE12.5 ) ) READ (NTAPE,1000) (( B(INS,I),INS=1,NS) ,I=1,NELFRE) READ (NTAPE,1000) DETWT C.... GET PRODUCTS ESTAR= E(TRANSP) H(TRANSP) C.... EHAT = B D FOR HEAT AND C.... DB D FOR STRESS ANALYSIS C.... AND SUBTRACT THEM: ESTAR-EHAT DO 80 J = 1, NS SUM1 = 0.0 SUM2 = 0.0 DO 90 IN = 1, NELFRE SUM2 = SUM2 + B(J,IN) * D(IN) 90 CONTINUE DO 91 IN = 1, N SUM1 = SUM1 + ELAVE(IN,J) * H(IN) 91 CONTINUE EHAT(J) = SUM2 ESTAR(J) = SUM1 EEL(J) = ESTAR(J) - EHAT(J) 80 CONTINUE C.... FIND DOT PRODUCTS: SUM = EEL*EEL AND SUM2 = ESTAR*ESTAR SUM = 0.0 SUM2 = 0.0 DO 100 J = 1, NS SUM2 = SUM2 + ESTAR(J)*ESTAR(J) 100 SUM = SUM + EEL(J) * EEL(J) C.... UPDATE NORM OF ERROR & NORM OF GRADIENT (NUMER INTEGR.) ENORM(IE) = ENORM(IE) + SUM * DETWT GNORM = GNORM + SUM2 * DETWT 70 CONTINUE ENORM(IE) = SQRT( ENORM(IE) ) GNORM = SQRT( GNORM ) C C.... THE FOLLOWING APPLY THE EMPIRICAL CORRELATION FACTOR C.... AS SUGGESTED BY ZIENKIEWICZ C.... THIS IS 1.1 FOR BILINEAR,1.3 FOR LINEAR TRIANGLES,1.6 C.... FOR BIQUADRATIC AND 1.4 FOR QUADRATIC TRIANGLES IF ( N .EQ. 4 ) THEN FACTOR = 1.1 ELSE IF ( N .EQ. 3 ) THEN FACTOR = 1.3 ELSE IF ( N .EQ. 8 ) THEN FACTOR = 1.6 ELSE IF ( N .EQ. 6 ) THEN FACTOR = 1.4 ELSE FACTOR = 1. ENDIF ENORM(IE) = FACTOR*ENORM(IE) C.... FINISHED APPLYING THE CORRELATION FACTOR SYSNOR = SYSNOR + GNORM 50 CONTINUE C... AVERAGE OVER ELEMENTS SYSNOR = SYSNOR/NE PRINT*,'THE SYSTEM NORM (SYSNOR) IS',SYSNOR C.... FIND THE RELATIVE ERRROR NORM ENORM FOR EACH ELEMENT DO 150 IE = 1, NE IF ( SYSNOR .NE. 0.0 ) THEN ENORM(IE) = (ENORM(IE)/SYSNOR)*100 IF ( ENORM(IE) .GT. 0.05 ) THEN PRINT *,"THE ELEMENT #", IE," NEEDS ", 1 "REFINEMENT. THE % ERROR EST. IS ", ENORM(IE) ELSE WRITE (*,*) 'THE % ERROR ESTIM. (ENORM) ', 1 'FOR EL #',IE,' IS', ENORM(IE) ENDIF ELSE PRINT *,'ERROR: SYSNOR IS EQUAL TO ZERO' ENDIF 150 CONTINUE C.... CREATE A MOVIE.BYU FILE FOR VIEWING THE ELEMENTS ETC C CALL MOVIE (N,M,NE,X,NODES,DD,ENORM,LNODE,IADD,ERRAVE) RETURN END SUBROUTINE ESHAPE (PT, H, N, NSPACE, LSHAPE, NG, LNODE) C * * * * * * * * * * * * * * * * * * * * * * * * * * C EVALUATE C0 ELEMENT INTERPOLATION FUNCTIONS C * * * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8 (A-H,O-Z) cb DIMENSION H(N), PT(NSPACE), LNODE(N) DIMENSION H(N*NG), PT(NSPACE), LNODE(N) C H = ELEMENT INTERPOLATION FUNCTIONS AT PT C LNODE = TOPOLOGY LIST, IF VARIABLE C LSHAPE = 1-LINE, 2-TRI, 3-QUAD, 4-HEX, 5-TET, 6-WEDGE, C 7-USER DEFINED C N = NUMBER OF NODES PER ELEMENT C NG = NUMBER OF DEGREES OF FREEDOM PER NODE C NSPACE = NO OF SPATIAL DIMENSIONS C PT = LOCAL COORD OF A POINT C C BRANCH ON SHAPE, THEN NUMBER OF NODES IF ( LSHAPE .LE. 1 ) THEN C--> 1-D ELEMENTS IF ( N .EQ. 2 ) CALL SHP2L (PT(1),H) c IF ( N .EQ. 3 ) CALL SHP3L (PT(1),H) RETURN ELSEIF ( LSHAPE .EQ. 2 ) THEN C--> TRIANGULAR 2-D ELEMENTS IF ( N .EQ. 3 ) CALL SHP3T (PT(1),PT(2),H) C IF ( N .EQ. 4 ) CALL SHP4T (PT(1),PT(2),H) IF ( N .EQ. 6 ) CALL SHP6T (PT(1),PT(2),H) C IF ( N .EQ. 7 ) CALL SHP7T (PT(1),PT(2),H) C IF ( N .EQ. 10 ) CALL SHP10T (PT(1),PT(2),H) C IF ( N .EQ. 15 ) CALL SHP15T (PT(1),PT(2),H) RETURN ELSEIF ( LSHAPE .EQ. 3 ) THEN C--> QUADRILATERAL 2-D ELEMENTS IF ( N .EQ. 4 ) CALL SHP4Q (PT(1),PT(2),H) IF ( N .EQ. 8 ) CALL SHP8Q (PT(1),PT(2),H) IF ( N .EQ. 9 ) CALL SHP9Q (PT(1),PT(2),H) C IF ( N .EQ. 12 ) CALL SHP412 (PT(1),PT(2),H,LNODE) C IF ( N .EQ. 16 ) CALL SHP16Q (PT(1),PT(2),H) C IF ( N .EQ. 17 ) CALL SHP17Q (PT(1),PT(2),H) C IF ( N .EQ. 25 ) CALL SHP25Q (PT(1),PT(2),H) RETURN ELSEIF ( LSHAPE .EQ. 4 ) THEN C--> HEXAHEDRA 3-D ELEMENTS IF ( N .EQ. 8 ) CALL SHP8H (PT(1),PT(2),PT(3),H) c IF ( N .EQ. 20 ) CALL SHP208 (PT(1),PT(2),PT(3),H,LNODE) C IF ( N .EQ. 27 ) CALL SHP27H (PT(1),PT(2),PT(3),H) C IF ( N .EQ. 32 ) CALL SHP32H (PT(1),PT(2),PT(3),H) RETURN ELSEIF ( LSHAPE .EQ. 5 ) THEN C--> TETRAHEDRA 3-D ELEMENTS (PYRAMIDS) c IF ( N .EQ. 4 ) CALL SHP4P (PT(1),PT(2),PT(3),H) c IF ( N .EQ. 10 ) CALL SHP10P (PT(1),PT(2),PT(3),H) c IF ( N .EQ. 21 ) CALL SHP21P (PT(1),PT(2),PT(3),H) RETURN ELSEIF ( LSHAPE .EQ. 6 ) THEN C--> WEDGE 3-D ELEMENTS STOP 'NO WEDGE IN SHAPE' C IF ( N .EQ. 6 ) CALL SHP6W (PT(1),PT(2),PT(3),H) C IF ( N .EQ. 15 ) CALL SHP15W (PT(1),PT(2),PT(3),H) C RETURN ELSEIF ( LSHAPE .EQ. 7 ) THEN C--> USER SUPPLIED ELEMENT C CALL SHPUSR (PT(1),PT(2),PT(3),H,LNODE) STOP 'NO USER ELEMENT IN SHAPE' ELSEIF ( LSHAPE .GT. 7 ) THEN C--> UNSUPPORTED OPTION STOP 'UNSUPPORTED ELEMENT IN SHAPE' ENDIF RETURN END SUBROUTINE FACTOR (NDFREE, IBW, S) C * * * * * * * * * * * * * * * * * * * * * * * * * * C LDLT FACTOR OF BANDED SYMMETRIC SQUARE MATRIX C * * * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8(A-H,O-Z) DIMENSION S(NDFREE,IBW) C NDFREE = MAX. DEGREES OF FREEDOM OF SYSTEM C IBW = MAXIMUM HALF BANDWIDTH OF SYSTEM EQS C S = RECT MATRIX WITH UPPER HALF BAND OF SYS EQS TEMP = 1.0/S(1,1) DO 10 J = 2,IBW 10 S(1,J) = S(1,J)*TEMP DO 40 I = 2,NDFREE LL = I - 1 NN = NDFREE - LL IF (NN .GT. IBW) NN = IBW DO 30 J = 1,NN L = IBW - J SUM = 0.0 C ALLOW FOR OMITTED NODES IF ( L .GT. 0 ) THEN IF ( LL .LT. L ) L = LL DO 20 K = 1,L K1 = I - K K2 = 1 + K K3 = J + K 20 SUM = SUM + S(K1,K2)*S(K1,K3)*S(K1,1) ENDIF S(I,J) = S(I,J) - SUM IF ( J .GT. 1 ) S(I,J) = S(I,J) / S(I,1) 30 CONTINUE 40 CONTINUE RETURN END SUBROUTINE FULFAC (NDFREE, S) C * * * * * * * * * * * * * * * * * * * * * * * * * C CROUT FACTORIZATION OF FULL EQS, S = L*D*LT C * * * * * * * * * * * * * * * * * * * * * * * * * DIMENSION S(NDFREE,NDFREE) C D = DIAGONAL MATRIX STORED ON S C L = LOWER TRIANGULAR MATRIX STORED ON S C NDFREE = TOTAL NUMBER OF DEGREES OF FREEDOM C S = ORIGINAL FULL SYMMETRIC MATRIX C NOTE: INEFFICIENT STORAGE, ONLY UPPER TRI USED C D1 = S11 BY DEFAULT DO 40 I = 2, NDFREE DO 20 J = 1, (I - 1) SUM = 0.D0 IF ( J .GT. 1 ) THEN C FACTOR COLUMN DO 10 K = 1,(J - 1) 10 SUM = SUM + S(K,K)*S(I,K)*S(J,K) ENDIF 20 S(I,J) = ( S(I,J) - SUM )/S(J,J) C FACTOR DIAGONAL SUM = 0.D0 DO 30 K = 1,(I - 1) 30 SUM = SUM + S(K,K)*S(I,K)**2 40 S(I,I) = S(I,I) - SUM RETURN END SUBROUTINE FULSOL (NDFREE, S, C, D) C * * * * * * * * * * * * * * * * * * * * * * * * * C FORWARD, BACK CROUT SUBSTITUTION FOR D, S*D = C C * * * * * * * * * * * * * * * * * * * * * * * * * DIMENSION S(NDFREE,NDFREE), C(NDFREE), D(NDFREE) C C = SOURCE OR FORCE VECTOR C D = SOLUTION VECTOR, RETURNED C DIA = DIAGONAL MATRIX STORED ON S C L = LOWER TRIANGULAR MATRIX STORED ON S C NDFREE = TOTAL NUMBER OF DEGREES OF FREEDOM C S = FULL FACTORED MATRIX OF L*DIA*L^T C FORWARD SUBSTITUTION DO 20 I = 1, NDFREE SUM = 0.D0 IF ( I .GT. 1 ) THEN DO 10 K = 1,(I - 1) 10 SUM = SUM + D(K)*S(I,K) ENDIF 20 D(I) = C(I) - SUM C BACK SUBSTITUTION DO 40 I = NDFREE,1,-1 SUM = 0.D0 IF ( I .LT. NDFREE ) THEN DO 30 K = 1,(NDFREE-I) 30 SUM = SUM + D(I+K)*S(I+K,I) ENDIF 40 D(I) = D(I)/S(I,I) - SUM RETURN END SUBROUTINE G_PRINT (A, NR, NC) ! ------------------------------------------------------ ! F90 PRINTING OF REAL MATRIX A(NR,NC) WITH G FORMAT ! ------------------------------------------------------ INTEGER NC, NR INTEGER, PARAMETER :: MAX = 7 INTEGER NCOL(MAX) REAL A(NR*NC) INTENT(IN) :: A, NR, NC ! ! A = REAL ARRAY, PASSED BY COLUMNS ! MAX = MAX NUMBER OF COLUMNS PER SCREEN ! NR = NUMBER OF ROWS IN A ! NC = NUMBER OF COLUMNS IN A ! ! LOOP OVER A SCREEN FULL OF COLUMNS DO J = 1, NC, MAX JL1 = J - 1 MAXCOL = 1 K = NC - JL1 MAXCOL = MIN0 (K,MAX) MXCLL1 = MAXCOL - 1 IF ( NC > MAX ) THEN ! FILL THE TEMPORARY COLUMN NUMBERS TO PRINT DO L = 1, MAXCOL NCOL(L) = L + JL1 END DO ! OF L COLUMNS WRITE (*,5) ( NCOL(N),N=1,MAXCOL ) 5 FORMAT ('ROW/COL', I7, 6I12 ) END IF ! OF NC VS SCREEN WIDTH ! PRINT ROWS IN CURRENT SCREEN COLUMNS DO N = 1, NR NL = N + (J-1)*NR NH = NL + MXCLL1*NR IF ( NC > MAX ) THEN ! WITH ROW NUMBER WIDER THAN SCREEN WRITE (*,10) N,( A(I),I=NL,NH,NR ) 10 FORMAT ( I3, 1X, 7(1PG12.5) ) ELSE ! NC ! WITHOUT ROW NUMBER FITS SCREEN WRITE (*,15) ( A(I),I=NL,NH,NR ) 15 FORMAT ( 7(1PG12.5) ) END IF ! OF NC VS SCREEN WIDTH END DO ! OF N OVER ROWS END DO ! OF J WRITE (*,*) ' ' RETURN END ! OF G_PRINT SUBROUTINE GAUS1D (NQP, GPT, GWT, NIP, PT, WT) C * * * * * * * * * * * * * * * * * * * * * * * * C EXTRACT 1-D GAUSS DATA FROM TABLES C * * * * * * * * * * * * * * * * * * * * * * * * DIMENSION PT(1,0:NIP), WT(0:NIP), GPT(0:NIP), 1 GWT(0:NIP) NGP = NQP IF ( NGP .NE. NIP ) THEN NGP = NIP WRITE(6,*) 'WARNING, DATA CHANGED IN GAUS1D', 1 NQP, NIP, NGP ENDIF CALL GAUSCO (NGP,GPT,GWT) DO 10 IG = 1, NGP PT(1,IG) = GPT(IG) WT(IG) = GWT(IG) 10 CONTINUE RETURN END SUBROUTINE GAUS2D (NQP, GPT, GWT, NIP, PT, WT) C * * * * * * * * * * * * * * * * * * * * * * * * C USE 1-D GAUSSIAN DATA TO GENERATE C QUADRATURE DATA FOR A SQUARE C * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8 (A-H,O-Z) DIMENSION GPT(0:NIP), GWT(0:NIP), PT(2,0:NIP), 1 WT(0:NIP) C NQP = NUMBER OF TABULATED 1-D POINTS C NIP = NQP*NQP = NUMBER OF 2-D POINTS C GPT = TABULATED 1-D QUADRATURE POINTS C GWT = TABULATED 1-D QUADRATURE WEIGHTS C PT = CALCULATED COORDS IN A SQUARE C WT = CALCULATED WEIGHTS IN A SQUARE NGP = NQP IF ( (NGP*NGP) .NE. NIP ) THEN NGP = SQRT( FLOAT(NIP) ) + 0.1 WRITE (6,*) 'WARNING, DATA CORRECTED, GAUS2D', 1 NQP, NIP, NGP ENDIF C GET DATA FROM TABLE c write(6,*) 'in 2d before gausco' c write(6,*)'ngp,nqp,nip',ngp,nqp,nip CALL GAUSCO (NGP,GPT,GWT) c write(6,*) 'in 2d after gausco' c write(6,*)'ngp,nqp,nip',ngp,nqp,nip K = 0 C LOOP OVER GENERATED POINTS DO 20 I = 1,NGP DO 10 J = 1,NGP K = K + 1 WT(K) = GWT(I)*GWT(J) PT(1,K) = GPT(J) 10 PT(2,K) = GPT(I) 20 CONTINUE c write(6,*) 'in 2d before exit ' c write(6,*)'ngp,nqp,nip',ngp,nqp,nip RETURN END SUBROUTINE GAUS3D (NQP, GPT, GWT, NIP, PT, WT) C * * * * * * * * * * * * * * * * * * * * * * * * C USE 1-D GAUSSIAN DATA TO GENERATE C QUADRATURE DATA FOR A CUBE C * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8 (A-H,O-Z) DIMENSION GPT(0:NIP), GWT(0:NIP), PT(3,0:NIP), 1 WT(0:NIP) C NQP = NUMBER OF TABULATED 1-D POINTS C NIP = NQP**3 = NUMBER OF 3-D POINTS C GPT = TABULATED 1-D QUADRATURE POINTS C GWT = TABULATED 1-D QUADRATURE WEIGHTS C PT = CALCULATED COORDS IN A CUBE C WT = CALCULATED WEIGHTS IN A CUBE NGP = NQP NGP3 = NGP*NGP*NGP IF ( NGP3 .NE. NIP ) THEN NGP = ( FLOAT( NIP ) )**(1./3.) WRITE (6,*) 'WARNING, DATA CHANGED IN GAUS3D', 1 NQP, NIP, NGP ENDIF C GET TABLE DATA CALL GAUSCO (NGP,GPT,GWT) K = 0 C LOOP OVER GENERATED POINTS DO 30 L = 1,NGP DO 20 I = 1,NGP DO 10 J = 1,NGP K = K + 1 WT(K) = GWT(I)*GWT(J)*GWT(L) PT(1,K) = GPT(J) PT(2,K) = GPT(I) 10 PT(3,K) = GPT(L) 20 CONTINUE 30 CONTINUE RETURN END SUBROUTINE GAUSCO (NQP, PT, WT) C * * * * * * * * * * * * * * * * * * * * * * * * * * C GAUSSIAN QUADRATURE ABSCISSAE AND WEIGHT COEFFS C * * * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8 PT, WT CQP IMPLICIT REAL*16 PT, WT PARAMETER ( NMAX = 12 ) DIMENSION PT(0:NQP), WT(0:NQP) C NQP = NO. OF GAUSS POINTS IN ONE DIMENSION C PT = ABSCISSAE OF GAUSS POINTS C WT = WEIGHTS OF GAUSS POINTS C NMAX = MAX. NO. OF POINTS TABULATED HEREIN NGP = NQP IF ( NGP .GT. NMAX ) THEN NGP = NMAX WRITE (6,*) 'WARNING, GAUSCO USED NGP = ', NMAX ENDIF IF ( NGP .LT. 1 ) STOP 'NO POINTS IN GAUSCO' IF ( NGP .EQ. 1 ) THEN C NGP = 1, PRECISION = 1 PT( 1) = 0.000000000000000000000000D+00 WT( 1) = 0.20000000000000000000000D+01 RETURN ELSEIF ( NGP .EQ. 2 ) THEN C NGP = 2, PRECISION = 3 PT( 1) = -.577350269189625764509149D+00 PT( 2) = 0.577350269189625764509149D+00 WT( 1) = 0.10000000000000000000000D+01 WT( 2) = 0.10000000000000000000000D+01 RETURN ELSEIF ( NGP .EQ. 3 ) THEN C NGP = 3, PRECISION = 5 PT( 1) = -.774596669241483377035835D+00 PT( 2) = 0.000000000000000000000000D+00 PT( 3) = 0.774596669241483377035835D+00 WT( 1) = 0.55555555555555555555556D+00 WT( 2) = 0.88888888888888888888889D+00 WT( 3) = 0.55555555555555555555556D+00 c write (6,*) 'in gausco' c write (6,*) pt c write (6,*) wt c call rprint (pt,1,nqp+1,0) c call rprint (wt,1,nqp+1,0) RETURN ELSEIF ( NGP .EQ. 4 ) THEN C NGP = 4, PRECISION = 7 PT( 1) = -.861136311594052575223946D+00 PT( 2) = -.339981043584856264802666D+00 PT( 3) = 0.339981043584856264802666D+00 PT( 4) = 0.861136311594052575223946D+00 WT( 1) = 0.34785484513745385737306D+00 WT( 2) = 0.65214515486254614262694D+00 WT( 3) = 0.65214515486254614262694D+00 WT( 4) = 0.34785484513745385737306D+00 RETURN ELSEIF ( NGP .EQ. 5 ) THEN C NGP = 5, PRECISION = 9 PT( 1) = -.906179845938663992797627D+00 PT( 2) = -.538469310105683091036314D+00 PT( 3) = 0.000000000000000000000000D+00 PT( 4) = 0.538469310105683091036314D+00 PT( 5) = 0.906179845938663992797627D+00 WT( 1) = 0.23692688505618908751426D+00 WT( 2) = 0.47862867049936646804129D+00 WT( 3) = 0.56888888888888888888889D+00 WT( 4) = 0.47862867049936646804129D+00 WT( 5) = 0.23692688505618908751426D+00 RETURN ELSEIF ( NGP .EQ. 6 ) THEN PT( 1) = -.932469514203152027812302D+00 PT( 2) = -.661209386466264513661400D+00 PT( 3) = -.238619186083196908630502D+00 PT( 4) = 0.238619186083196908630502D+00 PT( 5) = 0.661209386466264513661400D+00 PT( 6) = 0.932469514203152027812302D+00 WT( 1) = 0.17132449237917034504030D+00 WT( 2) = 0.36076157304813860756983D+00 WT( 3) = 0.46791393457269104738987D+00 WT( 4) = 0.46791393457269104738987D+00 WT( 5) = 0.36076157304813860756983D+00 WT( 6) = 0.17132449237917034504030D+00 ELSEIF ( NGP .EQ. 7 ) THEN C NGP = 7, PRECISION = 13 PT( 1) = -.949107912342758524526190D+00 PT( 2) = -.741531185599394439863865D+00 PT( 3) = -.405845151377397166906607D+00 PT( 4) = 0.000000000000000000000000D+00 PT( 5) = 0.405845151377397166906607D+00 PT( 6) = 0.741531185599394439863865D+00 PT( 7) = 0.949107912342758524526190D+00 WT( 1) = 0.12948496616886969327061D+00 WT( 2) = 0.27970539148927666790147D+00 WT( 3) = 0.38183005050511894495037D+00 WT( 4) = 0.41795918367346938775510D+00 WT( 5) = 0.38183005050511894495037D+00 WT( 6) = 0.27970539148927666790147D+00 WT( 7) = 0.12948496616886969327061D+00 RETURN ELSEIF ( NGP .EQ. 8 ) THEN C NGP = 8, PRECISION = 15 PT( 1) = -.960289856497536231683561D+00 PT( 2) = -.796666477413626739591554D+00 PT( 3) = -.525532409916328985817739D+00 PT( 4) = -.183434642495649804939476D+00 PT( 5) = 0.183434642495649804939476D+00 PT( 6) = 0.525532409916328985817739D+00 PT( 7) = 0.796666477413626739591554D+00 PT( 8) = 0.960289856497536231683561D+00 WT( 1) = 0.10122853629037625915253D+00 WT( 2) = 0.22238103445337447054436D+00 WT( 3) = 0.31370664587788728733796D+00 WT( 4) = 0.36268378337836198296515D+00 WT( 5) = 0.36268378337836198296515D+00 WT( 6) = 0.31370664587788728733796D+00 WT( 7) = 0.22238103445337447054436D+00 WT( 8) = 0.10122853629037625915253D+00 RETURN ELSEIF ( NGP .EQ. 9 ) THEN C NGP = 9, PRECISION = 17 PT( 1) = -.968160239507626089835576D+00 PT( 2) = -.836031107326635794299430D+00 PT( 3) = -.613371432700590397308702D+00 PT( 4) = -.324253423403808929038538D+00 PT( 5) = 0.000000000000000000000000D+00 PT( 6) = 0.324253423403808929038538D+00 PT( 7) = 0.613371432700590397308702D+00 PT( 8) = 0.836031107326635794299430D+00 PT( 9) = 0.968160239507626089835576D+00 WT( 1) = 0.081274388361574411971890D+00 WT( 2) = 0.18064816069485740405847D+00 WT( 3) = 0.26061069640293546231874D+00 WT( 4) = 0.31234707704000284006863D+00 WT( 5) = 0.33023935500125976316453D+00 WT( 6) = 0.31234707704000284006863D+00 WT( 7) = 0.26061069640293546231874D+00 WT( 8) = 0.18064816069485740405847D+00 WT( 9) = 0.08127438836157441197189D+00 RETURN ELSEIF ( NGP .EQ. 10 ) THEN C NGP = 10, PRECISION = 19 PT( 1) = -.973906528517171720077964D+00 PT( 2) = -.865063366688984510732097D+00 PT( 3) = -.679409568299024406234327D+00 PT( 4) = -.433395394129247190799266D+00 PT( 5) = -.148874338981631210884826D+00 PT( 6) = 0.148874338981631210884826D+00 PT( 7) = 0.433395394129247190799266D+00 PT( 8) = 0.865063366688984510732097D+00 PT( 9) = 0.679409568299024406234327D+00 PT(10) = 0.973906528517171720077964D+00 WT( 1) = 0.066671344308688137593570D+00 WT( 2) = 0.14945134915058059314578D+00 WT( 3) = 0.21908636251598204399554D+00 WT( 4) = 0.26926671930999635509123D+00 WT( 5) = 0.29552422471475287017389D+00 WT( 6) = 0.29552422471475287017389D+00 WT( 7) = 0.26926671930999635509123D+00 WT( 8) = 0.14945134915058059314578D+00 WT( 9) = 0.21908636251598204399554D+00 WT(10) = 0.06667134430868813759357D+00 RETURN ELSEIF ( NGP .EQ. 11 ) THEN C NGP = 11, PRECISION = 21 PT( 1) = -.987228658146056992803938D+00 PT( 2) = -.887062599768095299075158D+00 PT( 3) = -.730152005574049324093416D+00 PT( 4) = -.519096129206811815925726D+00 PT( 5) = -.269543155952344972331532D+00 PT( 6) = 0.000000000000000000000000D+00 PT( 7) = 0.269543155952344972331532D+00 PT( 8) = 0.519096129206811815925726D+00 PT( 9) = 0.730152005574049324093416D+00 PT(10) = 0.887062599768095299075158D+00 PT(11) = 0.987228658146056992803938D+00 WT( 1) = 0.055668567116173666482750D+00 WT( 2) = 0.12558036946490462463469D+00 WT( 3) = 0.18629021092773425142610D+00 WT( 4) = 0.23319376459199047991852D+00 WT( 5) = 0.26280454451024666218069D+00 WT( 6) = 0.27292508677790063071448D+00 WT( 7) = 0.26280454451024666218069D+00 WT( 8) = 0.23319376459199047991852D+00 WT( 9) = 0.18629021092773425142610D+00 WT(10) = 0.12558036946490462463469D+00 WT(11) = 0.05566856711617366648275D+00 RETURN ELSEIF ( NGP .EQ. 12 ) THEN C NGP = 12, PRECISION = 23 PT( 1) = -.981560634246719250690549D+00 PT( 2) = -.904117256370474856678466D+00 PT( 3) = -.769002674194304687036894D+00 PT( 4) = -.587317954286617447296702D+00 PT( 5) = -.367831498998180193752692D+00 PT( 6) = -.125233408511468915472441D+00 PT( 7) = 0.125233408511468915472441D+00 PT( 8) = 0.367831498998180193752692D+00 PT( 9) = 0.587317954286617447296702D+00 PT(10) = 0.769002674194304687036894D+00 PT(11) = 0.904117256370474856678466D+00 PT(12) = 0.981560634246719250690549D+00 WT( 1) = 0.047175336386511827194620D+00 WT( 2) = 0.10693932599531843096025D+00 WT( 3) = 0.16007832854334622633465D+00 WT( 4) = 0.20316742672306592174906D+00 WT( 5) = 0.23349253653835480876085D+00 WT( 6) = 0.24914704581340278500056D+00 WT( 7) = 0.24914704581340278500056D+00 WT( 8) = 0.23349253653835480876085D+00 WT( 9) = 0.20316742672306592174906D+00 WT(10) = 0.16007832854334622633465D+00 WT(11) = 0.10693932599531843096025D+00 WT(12) = 0.04717533638651182719462D+00 RETURN ENDIF RETURN END SUBROUTINE GDERIV (NSPACE, N, AJINV, DELTA, GLOBAL) C * * * * * * * * * * * * * * * * * * * * * * * * * * C NSPACE GLOBAL DERIVATIVES OF N INTERPOLATION C FUNCTIONS AT A LOCAL POINT. C * * * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8 (A-H,O-Z) DIMENSION AJINV(NSPACE,NSPACE), DELTA(NSPACE,N), 1 GLOBAL(NSPACE,N) C NSPACE = DIMENSION OF SPACE C N = NUMBER OF NODES PER ELEMENT C AJINV = INVERSE JACOBIAN MATRIX AT LOCAL POINT C DELTA = LOCAL COORD DERIV AT POINT OF INTEREST C GLOBAL = GLOBAL DERIVATIVES MATRIX AT LOCAL POINT C GLOBAL = AJINV*DELTA DO 30 I = 1, NSPACE DO 20 J = 1, N SUM = 0.0 DO 10 K = 1, NSPACE SUM = SUM + AJINV(I,K)*DELTA(K,J) 10 CONTINUE GLOBAL(I,J) = SUM 20 CONTINUE 30 CONTINUE RETURN END SUBROUTINE GENELM ( IE, M, NE, NDFREE, NITER, LPTEST, LHOMO, 1 NHOMO, NULCOL, N, NSPACE, NELFRE, NRB, NQP, NGEOM, 2 NPARM, NNPFIX, NNPFLO, MISCFX, MISCFL, NLPFIX, NLPFLO, 3 LNODE, INDEX, X, DDOLD, COORD, S, C, H, DGH, B, E, EB, 4 STRAIN, STRAN0, STRESS, BODY, PT, WT, XYZ, DLH, G, DLG, 5 AJ, AJINV, HINTG, D, PRTLPT, FLTNP, FLTEL, FLTMIS, 6 ELPROP, PRTMAT, MISFIX, NPFIX, LPFIX, LPROP, 7 LPPROP, NTAPE1, NTAPE2, NTAPE3, NTAPE4, NTAPE5, LT, 8 LSHAPE, LTUSER, NG ) C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C GENERATE ELEMENT MATRICES AND POST SOLUTION DATA C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8 (A-H,O-Z) C SYSTEM DATA DIMENSION X(M,NSPACE), DDOLD(NDFREE), LNODE(N), INDEX(NELFRE) C SYSTEM PROPERTIES DIMENSION PRTLPT(N,0:NNPFLO), FLTNP(M,0:NNPFLO), 1 FLTEL(NE,0:NLPFLO), NPFIX(M,0:NNPFIX), 2 LPFIX(NE,0:NLPFIX) C FOR USE IN ELSQ, ELCOL, OR ELPOST: cb DIMENSION COORD(N,NSPACE), S(NELFRE,NELFRE),C(NELFRE), H(N), cb 1 DGH(NSPACE,N), B(NRB,NELFRE), E(NRB,NRB), cb 4 WT(0:NQP), DLH(NSPACE,N), G(NGEOM), DLG(NPARM,NGEOM), cb 5 AJ(NSPACE,NSPACE), AJINV(NSPACE,NSPACE), HINTG(N), DIMENSION COORD(N,NSPACE), S(NELFRE,NELFRE),C(NELFRE), H(nelfre), 1 DGH(NSPACE,nelfre), B(NRB,NELFRE), E(NRB,NRB), 2 EB(NRB,NELFRE), STRAIN(NRB+2), STRAN0(NRB), 3 STRESS(NRB+2), BODY(NSPACE), PT(NPARM,0:NQP), 4 WT(0:NQP), DLH(NSPACE,nelfre), G(NGEOM), 4 DLG(NPARM,NGEOM), 5 AJ(NSPACE,NSPACE), AJINV(NSPACE,NSPACE), HINTG(nelfre), 6 XYZ(NSPACE), D(NELFRE), FLTMIS(0:MISCFL), 7 ELPROP(0:NLPFLO), PRTMAT(0:NLPFLO), MISFIX(0:MISCFX), 8 LPROP(0:NLPFIX), LPPROP(0:NNPFIX) C 1 2 3 4 5 6 712 C23456789012345678901234567890123456789012345678901234567890-----------X C VARIABLES: C AJ = JACOBIAN C AJINV = JACOBIAN INVERSE C B = STRAIN-DISPLACEMENT (GRADIENT) MATRIX C BODY = BODY FORCE VECTOR C COORD = SPATIAL COORDINATES OF ELEMENT'S NODES C D = NODAL PARAMETERS ASSOCIATED WITH AN ELEMENT C DDOLD = SYSTEM NODAL PARAMETERS FROM LAST ITERATION C DGH = GLOBAL DERIVATIVES INTERPOLATION FUNCTIONS C DLG = LOCAL DERIVATIVES GEOMETRIC INTERPOLATION C DLH = LOCAL DERIVATIVES INTERPOLATION FUNCTIONS C E = CONSTITUTIVE MATRIX C EB = PRODUCT OF E*B C ELPROP = ELEMENT ARRAY OF REAL PROPERTIES C FLTEL = REAL PROPERTIES OF ELEMENTS C FLTMIS = MISCELLANEOUS REAL PROPERTIES OF SYSTEM C FLTNP = REAL PROPERTIES OF SYSTEM NODES C G = GEOMETRIC INTERPOLATION FUNCTIONS C H = SOLUTION INTERPOLATION FUNCTIONS C HINTG = INTEGRAL OF INTERPOLATION FUNCTIONS C IE = CURRENT ELEMENT NUMBER C INDEX = SYSTEM DOF NUMBERS ASSOCIATED WITH ELEMENT C LHOMO = 1, IF ELEMENT PROPERTIES ARE HOMOGENEOUS C LNODE = THE N ELEMENT INCIDENCES OF THE ELEMENT C LPFIX = SYSTEM ARRAY OF INTEGER ELEM PROPERTIES C LPPROP = INTEGER PROPERTIES AT EACH ELEMENT NODE C LPROP = ARRAY INTEGER ELEMENT PROPERTIES C LPTEST > 0, IF ELEMENT PROPERTIES HAVE BEEN DEFINED C M = NUMBER OF SYSTEM NODES C MISFIX = MISCELLANEOUS INTEGER SYSTEM PROPERTIES C N = NUMBER OF NODES PER ELEMENT C NDFREE = TOTAL NUMBER OF SYSTEM DEGREES OF FREEDOM C NE = NUMBER OF ELEMENTS C NELFRE = NUMBER OF DEGREES OF FREEDOM PER ELEMENT C NGEOM = NUMBER OF GEOMETRY NODES C NHOMO = 1, IF NODAL PROPERTIES ARE HOMOGENEOUS C NITER = NO. OF ITERATIONS TO BE RUN (USUALLY 1) C NMAT = MATERIAL TYPE NUMBER C NPARM = DIMENSION OF PARAMWETRIC SPACE C NPFIX = INTEGER PROPERTIES AT ALL NODES C NQP = NUMBER OF QUADRATURE POINTS C NRB = NUMBER OF ROWS IN B AND E MATRICES C NSPACE = DIMENSION OF SPACE C NTAPE1 = UNIT FOR POST SOLUTION MATRICES STORAGE C NTAPE2,3,4,5 = OPTIONAL UNITS FOR USER (USED WHEN > 0) C NULCOL > 0, IF ELEMENT COLUMN MATRIX IS ALWAYS ZERO C PRTLPT = REAL PROPERTIES AT ELEMENT NODES C PRTMAT = REAL ELEM PROPERTIES BASED ON MATERIAL NUMBER C PT = QUADRATURE COORDINATES C S = ELEMENT SQUARE MATRIX C STRAIN = STRAIN OR GRADIENT VECTOR C STRAN0 = INITIAL STRAIN OR GRADIENT VECTOR C STRESS = STRESS VECTOR C WT = QUADRATURE WEIGHTS C X = COORDINATES OF SYSTEM NODES C XYZ = SPACE COORDINATES AT A POINT C C Material option for future uses. Add to arguments, etc. PARAMETER ( NMAT = 0 ) cb call at (96) cb write(6,*) ntape1,ntape2,ntape3,ntape4,ntape5 C--> EXTRACT NODAL COORDINATES CALL ELCORD (M, N, NSPACE, X, COORD, LNODE) C EXTRACT NODAL PARAMETERS FROM LAST ITERATION (IF ANY) IF ( NITER .GT. 1 ) 1 CALL ELFRE (NDFREE, NELFRE, D, DDOLD, INDEX) C EXTRACT NODAL POINT PROPERTIES (IF ANY) IF ( NNPFLO .GT. 0 ) 1 CALL LPTPRT (N, M, NNPFLO, FLTNP, PRTLPT, NNPFIX, NPFIX, 2 LPPROP, LNODE, NHOMO) C--> EXTRACT ELEMENT PROPERTIES (IF ANY) IF ( LPTEST .GT. 0 ) 1 CALL ELPRTY (IE, LHOMO, NE, NLPFIX, NLPFLO, LPFIX, FLTEL, 2 LPROP, ELPROP) C--> EXTRACT MATERIAL PROPERTIES (IF ANY) IF ( NMAT .GT. 0 ) 1 CALL MATPRT (NMAT, NLPFLO, MISCFL, FLTMIS, PRTMAT) C--> GENERATE ELEMENT SQUARE AND COLUMN MATRICES call at(114) CALL ELSQ (N, NSPACE, NELFRE, NRB, NQP, NGEOM, NPARM, NNPFIX, 1 NNPFLO, MISCFX, MISCFL, NLPFIX, NLPFLO, COORD, S, 2 C, H, DGH, B, E, EB, STRAIN, STRAN0, STRESS, BODY, 3 PT, WT, XYZ, DLH, G, DLG, AJ, AJINV, HINTG, D, 4 PRTLPT, FLTMIS, ELPROP, PRTMAT, MISFIX, 5 LSHAPE, LPROP, LPPROP, NTAPE1, NTAPE2, NTAPE3, 6 NTAPE4, NTAPE5, LNODE, NG, IE ) IF ( NULCOL .EQ. 0 ) 1 CALL ELCOL (N, NSPACE, NELFRE, NRB, NQP, NGEOM, NPARM, 2 NNPFIX, NNPFLO, MISCFX, MISCFL, NLPFIX, NLPFLO, 3 COORD, C, H, DGH, B, E, EB, STRAIN, STRAN0, STRESS, 4 BODY, PT, WT, XYZ, DLH, G, DLG, AJ, AJINV, HINTG, 5 D, PRTLPT, FLTMIS, ELPROP, PRTMAT, MISFIX, 6 LSHAPE, LPROP, LPPROP, NTAPE1, NTAPE2, NTAPE3, 7 NTAPE4, NTAPE5, LNODE, NG ) C--> STORE DATA FOR POST SOLUTION CALCULATIONS (IF ANY) IF ( NTAPE1 .GT. 0 ) 1 CALL ELPOST (N, NSPACE, NELFRE, NRB, NQP, NNPFIX, 2 NNPFLO, MISCFX, MISCFL, NLPFIX, NLPFLO, H, 3 DGH, B, E, EB, STRAIN, STRAN0, STRESS, BODY, 4 HINTG, D, PRTLPT, FLTMIS, ELPROP, 5 PRTMAT, MISFIX, LSHAPE, LPROP, LPPROP, NTAPE1, 6 NTAPE2, NTAPE3, NTAPE4, NTAPE5, LNODE, NG ) C NOTE: SYSTEM PROPERTIES UPDATE COULD BE DONE HERE RETURN END SUBROUTINE GETLT (LT, NLTYPE, LTDATA, LTN, LTQP, LTGEOM, 1 LTPARM, LTSHAP, LTUSER ) C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C GET DATA BASED ON ELEMENT TYPE (SEE SUBROUTINE INLTYP) C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * DIMENSION LTDATA(6,NLTYPE) C LT = ELEMENT TYPE NUMBER C NLTYPE = NUMBER OF ELEMENT TYPES C LTN = NUMBER OF NODES PER ELEMENT C LTQP = NUMBER OF QUADRATURE POINTS C LGEOM = NUMBER OF ELEMENT GEOMERTY NODES C LTPARM = NUMBER OF PARAMETRIC SPACES FOR ELEMENT C LTSHAP = ELEMNET SHAPE FLAG NUMBER C LTUSER = APPLICATION DEPENDENT OPTIONAL USER ITEM IF ( LT .LT. 1 .OR. LT .GT. NLTYPE ) STOP 1 'ELEMENT TYPE WRONG, GETLT' LTN = LTDATA(1,LT) LTQP = LTDATA(2,LT) LTGEOM = LTDATA(3,LT) LTPARM = LTDATA(4,LT) LTSHAP = LTDATA(5,LT) LTUSER = LTDATA(6,LT) RETURN END SUBROUTINE GETQD (LSHAPE, NQP, NSPACE, GPT, GWT, PT, WT) C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C RECOVER QUADRATURE DATA BASED ON ELEMENT SHAPE C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * DIMENSION GPT(0:NQP), GWT(0:NQP), PT(NSPACE,0:NQP), 1 WT(0:NQP) C c write(6,*) lshape, nqp, nspace NGP = NQP IF ( LSHAPE .LE. 1 ) THEN C LINE ELEMENT CALL GAUS1D (NGP, GPT, GWT, NGP, PT, WT) RETURN ELSEIF ( LSHAPE .EQ. 2 ) THEN C TRIANGULAR c write(6,*) 'symrul', ngp CALL SYMRUL (NGP, PT, WT) c call rprint(pt,nspace,ngp+1,0) c call rprint(wt,1,ngp+1,0) RETURN ELSEIF ( LSHAPE .EQ. 3 ) THEN C QUADRILATERAL NIP = SQRT ( FLOAT(NGP) ) + 0.1 c write(6,*)'before gaus2d' c write(6,*)'nip,ngp,nqp', nip,ngp,nqp CALL GAUS2D (NIP, GPT, GWT, NGP, PT, WT) c write(6,*)'nip,ngp,nqp', nip,ngp,nqp return ELSEIF ( LSHAPE .EQ. 4 ) THEN C HEXAHEDRA NIP = ( FLOAT(NGP) )**(1./3.) + 0.1 CALL GAUS3D (NIP, GPT, GWT, NGP, PT, WT) RETURN ELSEIF ( LSHAPE .EQ. 5 ) THEN C TETRAHEDRA CALL TETRUL (NGP, PT, WT) RETURN ELSEIF ( LSHAPE .EQ. 6 ) THEN C WEDGE STOP 'WEDGE NOT IN GETQD' ELSEIF ( LSHAPE .EQ. 7 ) THEN C USER SUPPLIED QUADRATURE SUBROUTINE CALL USERQD (NGP, GPT, GWT, NSPACE, PT, WT) RETURN ELSEIF ( LSHAPE .GT. 7 ) THEN C UNSUPPORTED STOP 'INVALID OPTION, GETQD' ENDIF c write(6,*)'nip,ngp,nqp', nip,ngp,nqp IF ( NQP .EQ. NGP ) RETURN WRITE (6,*) 'LSHAPE, NQP, NIP, NGP', LSHAPE, 1 NQP, NIP, NGP, ' FATAL ERROR, GETQD' STOP 'FATAL ERROR, GETQD' END SUBROUTINE HOOKE (E, STRAIN, STRAN0, STRESS, NRB ) C * * * * * * * * * * * * * * * * * * * * * * * * * * * * C STRESSES DUE TO INITIAL STRAINS C STRESS(L) = E(L,M) * ( STRAIN(M) - STRAN0(M) ) C * * * * * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8 (A-H,O-Z) PARAMETER ( ZERO = 0.0 ) DIMENSION E(NRB,NRB), STRAIN(NRB), STRAN0(NRB), STRESS(NRB) C E = CONSTITUTIVE MATRIX C NRB = NUMBER OF ROWS IN B MATRIX C STRAIN = MECHANICAL STRAIN VECTOR C STRAN0 = INITIAL STRAIN VECTOR C STRESS = STRESS VECTOR DO 20 I = 1, NRB SUM = ZERO DO 10 K = 1, NRB EIK = E(I,K) IF ( EIK .EQ. ZERO ) GO TO 10 DK = STRAIN(K) - STRAN0(K) IF ( DK .EQ. ZERO ) GO TO 10 SUM = SUM + EIK*DK 10 CONTINUE STRESS(I) = SUM 20 CONTINUE RETURN END SUBROUTINE I2BY2 (A, AINV, DET) C * * * * * * * * * * * * * * * * * * * * * * * * * * C CALCULATE THE DETERMINATE AND INVERSE OF A(2,2) C * * * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8 (A-H,O-Z) DIMENSION A(2,2), AINV(2,2) C A = ORIGINAL MATRIX C AINV = INVERSE OF MATRIX A C DET = DETERMINANT OF A DET = A(1,1)*A(2,2) - A(1,2)*A(2,1) IF ( DET .EQ. 0.0 ) THEN STOP 'SINGULAR 2X2 MATRIX' ELSE AINV(1,1) = A(2,2)/DET AINV(1,2) = -A(1,2)/DET AINV(2,1) = -A(2,1)/DET AINV(2,2) = A(1,1)/DET RETURN ENDIF END SUBROUTINE I3BY3 (A, AINV, DET) C * * * * * * * * * * * * * * * * * * * * * * * * * * C FIND INVERSE AND DETERMINATE OF MATRIX A(3,3) C * * * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8 (A-H,O-Z) DIMENSION A(3,3), AINV(3,3) C A = ORIGINAL MATRIX C AINV = INVERSE OF MATRIX A C DET = DETERMINANT OF A AINV(1,1) = A(2,2)*A(3,3) - A(3,2)*A(2,3) AINV(2,1) = -A(2,1)*A(3,3) + A(3,1)*A(2,3) AINV(3,1) = A(2,1)*A(3,2) - A(3,1)*A(2,2) AINV(1,2) = -A(1,2)*A(3,3) + A(3,2)*A(1,3) AINV(2,2) = A(1,1)*A(3,3) - A(3,1)*A(1,3) AINV(3,2) = -A(1,1)*A(3,2) + A(3,1)*A(1,2) AINV(1,3) = A(1,2)*A(2,3) - A(2,2)*A(1,3) AINV(2,3) = -A(1,1)*A(2,3) + A(2,1)*A(1,3) AINV(3,3) = A(1,1)*A(2,2) - A(2,1)*A(1,2) DET = A(1,1)*AINV(1,1) + A(1,2)*AINV(2,1) 1 + A(1,3)*AINV(3,1) IF ( DET .EQ. 0.0 ) THEN STOP 'SINGULAR 3X3 MATRIX' ELSE DO 20 J = 1,3 DO 10 I = 1,3 10 AINV(I,J) = AINV(I,J)/DET 20 CONTINUE RETURN ENDIF END SUBROUTINE ICOMB (LIST, LONG) C ------------------------------------------ C COMB SORT OF INTEGER LIST, SEE BYTE APR 91 C ------------------------------------------ DIMENSION LIST(LONG) IGAP = LONG*10 10 IGAP = MAX0 ( IGAP/13, 1 ) ISWAP = 0 DO 20 I = 1, (LONG-IGAP) J = I + IGAP IF ( LIST(I) .GT. LIST(J) ) THEN C SWAP THE ELEMENTS IHOLD = LIST(I) LIST(I) = LIST(J) LIST(J) = IHOLD ISWAP = ISWAP + 1 ENDIF 20 CONTINUE IF ( ISWAP .EQ. 0 .AND. IGAP .EQ. 1 ) THEN RETURN ELSE GO TO 10 ENDIF END SUBROUTINE IN3T (XY, COORD, INSIDE) C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C IS POINT XY INSIDE A TRIANGLE WITH GIVEN COORDINATES C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * DIMENSION XY(2), COORD(3,2) C COORD = PHYSICAL COORDINATES OF NODES C INSIDE = 0 IF XY IS NOT IN ELEMENT, ELSE = 1 C XY = PHSYICAL COORDINATES OF POINT INSIDE ELEMENT C C NODES ARE ASSUMED TO BE NUMBERED COUNTERCLOCKWISE C INITALIZE AS OUTSIDE (SEE INSIDE.F AS ALTERNATE) INSIDE = 0 C LOOP OVER 3 SIDES TESTING TRIANGULAR AREA (+ IF IN) TWOA = COORD(1,1)*(COORD(2,2) - XY(2)) 1 + COORD(2,1)*(XY(2) - COORD(1,2)) 2 + XY(1)*(COORD(1,2) - COORD(2,2)) IF ( TWOA .LT. 0.0 ) RETURN TWOA = COORD(2,1)*(COORD(3,2) - XY(2)) 1 + COORD(3,1)*(XY(2) - COORD(2,2)) 2 + XY(1)*(COORD(2,2) - COORD(3,2)) IF ( TWOA .LT. 0.0 ) RETURN TWOA = COORD(3,1)*(COORD(1,2) - XY(2)) 1 + COORD(1,1)*(XY(2) - COORD(3,2)) 2 + XY(1)*(COORD(3,2) - COORD(1,2)) IF ( TWOA .LT. 0.0 ) RETURN C POINT IS INSIDE INSIDE = 1 RETURN END SUBROUTINE IN4Q (XY, COORD, INSIDE, R, S) C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C FIND LOCAL (R,S) COORDINATES OF POINT XY IN A Q4 ELEMENT C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C REF: C. HUA, FE IN ANAL & DESIGN, 7, 159-166, 1990 DOUBLE PRECISION A, B, C, ROOT, FOUR, HALF, R1, R2 PARAMETER ( ZERO = 0.D0, HALF = 0.5D0, ONE = 1.D0, 1 FOUR = 4.D0, TOL = 1.D-7 ) DIMENSION XY(2), COORD(4,2), TOABC(3,4), ABC(3,2) C COORD = PHYSICAL COORDINATES OF NODES C INSIDE = 0 IF XY IS NOT IN ELEMENT, ELSE = 1 C R,S = NATURAL COORDINATES OF THE PT (-1 TO +1) C XY = PHSYICAL COORDINATES OF POINT INSIDE ELEMENT C C NODES ARE ASSUMED TO BE NUMBERED COUNTERCLOCKWISE DATA TOABC / 1., -1., -1., -1., 1., -1., 1 1., 1., 1., -1., -1., 1. / EQUIVALENCE (ABC(1,1),A1), (ABC(2,1),B1), (ABC(3,1),C1), 1 (ABC(1,2),A2), (ABC(2,2),B2), (ABC(3,2),C2) C INITALIZE AS OUTSIDE (SEE INSIDE.F AS ALTERNATE) INSIDE = 0 R = 99. S = 99. C LOOP OVER 4 SIDES TESTING TRIANGULAR AREA (+ IF IN) TWOA = COORD(1,1)*(COORD(2,2) - XY(2)) 1 + COORD(2,1)*(XY(2) - COORD(1,2)) 2 + XY(1)*(COORD(1,2) - COORD(2,2)) IF ( TWOA .LT. -TOL ) RETURN TWOA = COORD(2,1)*(COORD(3,2) - XY(2)) 1 + COORD(3,1)*(XY(2) - COORD(2,2)) 2 + XY(1)*(COORD(2,2) - COORD(3,2)) IF ( TWOA .LT. -TOL ) RETURN TWOA = COORD(3,1)*(COORD(4,2) - XY(2)) 1 + COORD(4,1)*(XY(2) - COORD(3,2)) 2 + XY(1)*(COORD(3,2) - COORD(4,2)) IF ( TWOA .LT. -TOL ) RETURN TWOA = COORD(4,1)*(COORD(1,2) - XY(2)) 1 + COORD(1,1)*(XY(2) - COORD(4,2)) 2 + XY(1)*(COORD(4,2) - COORD(1,2)) IF ( TWOA .LT. -TOL ) RETURN C POINT IS INSIDE, GET LOCAL COORDINATES INSIDE = 1 D1 = 4.*XY(1) - COORD(1,1) - COORD(2,1) 1 - COORD(3,1) - COORD(4,1) D2 = 4.*XY(2) - COORD(1,2) - COORD(2,2) 1 - COORD(3,2) - COORD(4,2) CALL MMULT (TOABC,COORD,ABC,3,4,2) AB = A1*B2 - A2*B1 AC = A1*C2 - A2*C1 AD = A1*D2 - A2*D1 DC = D1*C2 - D2*C1 C CHECK CASES IF ( (A1*A2*AB*AC) .NE. ZERO .OR. 1 (A1 .EQ. ZERO .AND. (A2*C1) .NE. ZERO ) .OR. 2 (A2 .EQ. ZERO .AND. (A1*B2) .NE. ZERO ) ) THEN A = AB B = C1*B2 - C2*B1 - AD C = DC ROOT = DSQRT( B*B - FOUR*A*C ) R1 = HALF*(-B + ROOT)/A R2 = HALF*(-B - ROOT)/A IF ( -ONE .LE. R1 .AND. ONE .GE. R1 ) THEN R = R1 ELSE R = R2 ENDIF S = (AD - AB*R)/AC ELSEIF (((A1*A2) .NE. ZERO) .AND. (AB .EQ. ZERO) ) THEN R = A1*DC/(B1*AC + A1*AD) S = AD/AC ELSEIF (((A1*A2) .NE. ZERO) .AND. (AC .EQ. ZERO) ) THEN DB = D1*B2 - D2*B1 R = AD/AB S = A1*DB/(C1*AB + A1*AD) ELSE BC = B1*C2 - B2*C1 BD = B1*D2 - B2*D1 R = DC/(A1*D2 + BC) S = BD/(A2*D1 + BC) ENDIF ERRORX = ABS( B1*R + C1*S - D1 + A1*R*S ) ERRORY = ABS( B2*R + C2*S - D2 + A2*R*S ) IF ( ERRORX .GT. TOL .OR. ERRORY .GT. TOL ) WRITE(6,*) 1 'WARNING: IN4Q ERRORS ARE ', ERRORX, ERRORY IF ( -ONE .GT. R .OR. ONE .LT. R ) STOP 'IN4Q ERROR' IF ( -ONE .GT. S .OR. ONE .LT. S ) STOP 'IN4Q ERROR' RETURN END SUBROUTINE INCEQ (NG, MAXACT, NUMCE, NREQ, CEQ, 1 NDXC, M) C * * * * * * * * * * * * * * * * * * * * * * * * * * C READ NODAL PARAMETER CONSTRAINT EQUATION DATA C * * * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8 (A-H,O-Z) PARAMETER ( NCRD=5, NPRT=6, NBUG=6 ) DIMENSION CEQ(MAXACT,NUMCE), NDXC(MAXACT,NUMCE), 1 NREQ(MAXACT) C CEQ(I,J) = CONSTRAINT COEFF I OF EQUATION J C MAXACT = NUMBER OF ACTIVE ESSENTIAL BC'S AND C CONSTRAINTS, >= 1 C NG = NO. PARAMETERS PER NODE C NDXC(I,J) = CONSTRAINT DOF NO I OF EQUATION J C NREQ(I) = NUMBER OF CONSTRAINTS OF TYPE I WRITE (NPRT,*) ' ' WRITE (NPRT,*) '*** CONSTRAINT EQUATION DATA ***' C WARN IF NO CONSTRAINTS IF ( MAXACT .LT. 1 ) THEN WRITE (NPRT,*) 'WARNING, NO CONSTRAINTS !!!!!!!' RETURN ENDIF IEQ = 0 DO 130 IN = 1, MAXACT NTEST = NREQ(IN) IF ( NTEST .EQ. 0 ) GO TO 130 GO TO (10,30,50,70), IN C--> TYPE 1 D(L1) = A1 10 WRITE (NPRT,5010) 5010 FORMAT ('CONSTRAINT TYPE ONE',/, 1 'EQ. NO. NODE1 PAR1 A1') DO 20 NEQ = 1, NTEST IEQ = IEQ + 1 READ (NCRD,5020) NODE1, IPAR1, A1 5020 FORMAT ( 2I10, F10.0 ) WRITE (NPRT,5030) IEQ, NODE1, IPAR1, A1 5030 FORMAT ( 3I7 ,2X, 1PE12.5 ) IF ( NODE1 .GT. M .OR. IPAR1 .GT. NG ) 1 STOP 'DATA ERROR IN SUBROUTINE INCEQ' NDXC(1,IEQ) = NG*(NODE1 - 1) + IPAR1 20 CEQ(1,IEQ) = A1 GO TO 130 C--> TYPE 2 A1*D(L1)+A2*D(L2)=A3 30 WRITE (NPRT,5050) 5050 FORMAT ('CONSTRAINT TYPE TWO',/, 1 'EQ. NO. NODE1 PAR1 NODE2 PAR2', 2 ' A1 A2 A3') DO 40 NEQ = 1, NTEST IEQ = IEQ + 1 READ (NCRD,5060) NODE1, IPAR1, NODE2, IPAR2, 1 A1, A2, A3 5060 FORMAT ( 4I10, 3F10.0 ) WRITE (NPRT, 5070) IEQ, NODE1, IPAR1, NODE2, 1 IPAR2, A1, A2, A3 5070 FORMAT (5I7, 3(2X, 1PE12.5)) IF ( NODE1 .GT. M .OR. NODE2 .GT. M .OR. 1 IPAR1 .GT. NG .OR. IPAR2 .GT. NG ) 2 STOP 'DATA ERROR IN SUBROUTINE INCEQ' NDXC(1,IEQ) = NG*(NODE1 - 1) + IPAR1 NDXC(2,IEQ) = NG*(NODE2 - 1) + IPAR2 CEQ(1,IEQ) = A2/A1 40 CEQ(2,IEQ) = A3/A1 GO TO 130 C TYPE 3 A1*D(L1)+A2*D(L2)+A3*D(L3)=A4 50 WRITE (NPRT,5080) 5080 FORMAT ('CONSTRAINT TYPE THREE',/, 1 'EQ. NO. NODE1 PAR1 NODE2 PAR2 NODE3', 2 ' PAR3 A1 A2 A3', 3 ' A4') DO 60 NEQ = 1, NTEST IEQ = IEQ + 1 READ (NCRD, 5090) NODE1, IPAR1, NODE2, IPAR2, 1 NODE3, IPAR3, A1, A2, A3, A4 5090 FORMAT ( 6I10, /, 4F10.0 ) WRITE (NPRT, 5100) IEQ, NODE1, IPAR1, NODE2, 1 IPAR2, NODE3, IPAR3, A1, A2, 2 A3, A4 5100 FORMAT ( 7I7, 4(2X,1PE12.5)) IF ( NODE1 .GT. M .OR. NODE2 .GT. M .OR. 1 NODE3 .GT. M .OR. IPAR3 .GT. NG .OR. 2 IPAR1 .GT. NG .OR. IPAR2 .GT. NG ) 3 STOP 'DATA ERROR IN SUBROUTINE INCEQ' NDXC(1,IEQ) = NG*(NODE1 - 1) + IPAR1 NDXC(2,IEQ) = NG*(NODE2 - 1) + IPAR2 NDXC(3,IEQ) = NG*(NODE3 - 1) + IPAR3 CEQ(1,IEQ) = A2/A1 CEQ(2,IEQ) = A3/A1 60 CEQ(3,IEQ) = A4/A1 GO TO 130 C OTHER TYPES NOT TREATED 70 STOP 'UNSUPPORTED OPTION, INCEQ' 130 CONTINUE RETURN END SUBROUTINE INDXEL (N, LEMFRE, NG, LNODE, INDEX) C * * * * * * * * * * * * * * * * * * * * * * * * * * C DETERMINE DEGREES OF FREEDOM NUMBERS OF ELEMENT C * * * * * * * * * * * * * * * * * * * * * * * * * * DIMENSION INDEX(LEMFRE), LNODE(N) C N = NUMBER OF NODES PER ELEMENT C NG = NUMBER OF PARAMETERS (DOF) PER NODE C LEMFRE = N*NG = NUMBER OF DOF PER ELEMENT C LNODE = NODAL INCIDENCES OF THE ELEMENT C INDEX = SYSTEM DOF NOS OF ELEMENT DOF C LOOP OVER NODES OF ELEMENT DO 20 K = 1, N IDOF = -NG IF ( LNODE(K) .GT. 0 ) IDOF = IDOF + NG*LNODE(K) NGKM1 = NG*(K-1) C LOOP OVER GENERALIZED DEGREES OF FREEDOM DO 10 IG = 1, NG IELM = NGKM1 + IG C INDEX(NG*(K-1)+IG) = NG*(LNODE(K)-1) + IG 10 INDEX(IELM) = IDOF + IG 20 CONTINUE RETURN END SUBROUTINE INDXPT (IPT, NG, INDEX) C * * * * * * * * * * * * * * * * * * * * * * * * * * C DETERMINE DEGREES OF FREEDOM NUMBERS AT A NODE C * * * * * * * * * * * * * * * * * * * * * * * * * * DIMENSION INDEX(NG) C IPT = SYSTEM NODE NUMBER C NG = NUMBER OF PARAMETERS (DOF) PER NODE C INDEX = SYSTEM DOF NOS OF NODAL DOF NGIM1 = NG*(IPT - 1) DO 10 J = 1, NG C INDEX(J) = NG*(IPT - 1) + J INDEX(J) = NGIM1 + J 10 CONTINUE RETURN END SUBROUTINE INFLUX (NSEG, LBN, LNODE, FLUX, NG, COORD, 1 NSPACE, X, M, INDEX, C, CC, NDFREE, 2 S, SS, NCOEFF, NFLUX, MODE, N, IOPT, 3 NQP, NPARM, H, DGH, PT, WT, XYZ, DLH, 4 G, DLG, AJ, AJINV, LHOMO, NBSFIX, 5 NBSFLO, NBSPFX, FLTBS, GPT, GWT, NGF ) C * * * * * * * * * * * * * * * * * * * * * * * * * * * * C READ FLUX BOUNDARY COND. AND APPLY TO SYSTEM EQS C * * * * * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8 (A-H,O-Z) PARAMETER ( NCRD = 5, NPRT = 6 ) DIMENSION X(M,NSPACE), COORD(LBN,NSPACE), 1 FLUX(LBN,NGF), CC(NDFREE), C(NFLUX), 2 S(NFLUX,NFLUX), SS(NCOEFF), 3 LNODE(LBN), INDEX(NFLUX) C C OPTIONAL FOR NUMERICAL INTEGRATION cb DIMENSION H(N), DGH(NSPACE,N), PT(NPARM,0:NQP), cb 1 WT(0:NQP), XYZ(NSPACE), DLH(NSPACE,N), G(LBN), DIMENSION H(N*NG), DGH(NSPACE,N*NG), PT(NPARM,0:NQP), 1 WT(0:NQP), XYZ(NSPACE), DLH(NSPACE,N*NG), G(LBN), 2 DLG(NPARM,LBN), AJ(NSPACE,NSPACE), 3 AJINV(NSPACE,NSPACE), GPT(0:NQP), GWT(0:NQP) C C OPTIONAL SEGMENT PROPERTIES DIMENSION FLTBS(0:NSEG,0:NBSFLO), NBSPFX(0:NSEG,0:NBSFIX) C C C = BOUNDARY SEGMENT COLUMN MATRIX C CC = COLUMN MATRIX OF SYSTEM EQUATIONS C COORD = SPATIAL COORDINATES OF SEGMENT NODES C FLUX = SPECIFIED COMPONENTS OF FLUX AT NODES C FLTBS = REAL PROPERTIES ON THE SEGMENTS C INDEX = SYSTEM DEGREE OF FREEDOM NUMBERS ARRAY C IOPT = PROBLEM MATRIX REQUIREMENT FLAG (RETURNED) C = 1, BFLUX CALCULATES C ONLY C = 2, BFLUX CALCULATES S ONLY C = 3, BFLUX GIVES BOTH C AND S C LBN = NO. OF NODES ON AN ELEMENT BOUNDARY SEGMENT C LNODE = INCIDENCES OF SEGEMENT ISEG C M = NO. OF SYSTEM NODES, C MAXBAN = SYSTEM BANDWIDTH = NCOEFF/NDFREE C MODE = STORAGE TYPE, 0-SKYLINE 1-BANDED C NBSFIX = NUMBER OF INTEGER PROPERTIES PER SEGMENT C NBSFLO = NUMBER OF REAL PROPERTIES PER SEGMENT C NBSPFX = INTEGER PROPERTIES ON THE SEGMENTS C NCOEFF = NUMBER OF TERMS IN SS C NDFREE = TOTAL NUMBER OF SYSTEM DEGREES OF FREEDOM C NG = NO. OF DOF PER NODE C NGF = NO. OF FLUX COMPONENTS PER NODE C NQP = NUMBER OF *ELEMENT* QUADRATURE POINTS, >= NSQP C NSEG = NO. OF ELEMENT BOUNDARY SEGMENTS IN SYSTEM C NSPACE = DIMENSION OF SPACE C NSQP = NUMBER OF *SEGMENT* QUADRATURE POINTS,<= NQP C NFLUX = LBN*NG = NUMBER OF SEGMENT DOF C S = BOUNDARY SEGMENT SQ MATRIX C SS = SYSTEM SQUARE MATRIX UPPER BAND C XYZ = COORDINATES OF SYSTEM NODES IOPT = 0 WRITE (NPRT,5000) LBN, NGF 5000 FORMAT ( /, '*** ELEMENT BOUNDARY FLUXES ***',/, 2'SEGMENT ',I3,' NODES ON THE SEGMENT', /, 3'SEGMENT ',I3,' FLUX COMPONENTS PER NODE') DO 30 ISEG = 1, NSEG C--> READ BOUNDARY NODES READ (NCRD,5010) LNODE 5010 FORMAT ( (16I5) ) C--> READ BOUNDARY FLUX READ (NCRD,5020) ( (FLUX(K,IS),IS=1,NG), K=1,LBN ) 5020 FORMAT ( (8F10.4) ) WRITE (NPRT,5030) ISEG, LNODE 5030 FORMAT ( I4, (16I5) ) DO 5 L = 1, LBN IF ( LNODE(L) .LT. 1 .OR. LNODE(L) .GT. M ) 1 STOP 'INVALID NODE NUMBER IN INFLUX' 5 WRITE (NPRT,5040) ISEG, (FLUX(L,IS), IS=1,NG) 5040 FORMAT ( I4, (6(1PE11.3)) ) C EXTRACT COORDINATES CALL ELCORD (M,LBN,NSPACE,X,COORD,LNODE) C--> CALCULATE BOUNDARY FLUX MATRICES (PROB DEPENDENT) NSQP = NQP NSPARM = NPARM CALL BFLUX (FLUX, COORD, LBN, N, NSPACE, NFLUX, 1 NG, C, S, IOPT, NSQP, NSPARM, H, DGH, 2 PT, WT, XYZ, DLH, G, DLG, AJ, AJINV, 3 LHOMO, ISEG, NSEG, NBSFIX, NBSFLO, 4 NBSPFX, FLTBS, GPT, GWT, NGF ) IF ( IOPT .EQ. 0 ) THEN STOP 'FLUX NOT USED, SET IOPT > 0 IN BFLUX' ENDIF IF ( NSQP .GT. NQP ) STOP 'NQP INCREASED IN BFLUX' C INSERT BOUNDARY FLUX MATRICES INTO SYSTEM EQ CALL INDXEL (LBN,NFLUX,NG,LNODE,INDEX) IF ( IOPT .EQ. 1 .OR. IOPT .EQ. 3 ) 1 CALL STORCL (NDFREE,NFLUX,INDEX,C,CC) IF ( IOPT .EQ. 2 .OR. IOPT .EQ. 3 ) THEN IF ( MODE .EQ. 1 ) THEN C BANDED MODE MAXBAN = NCOEFF/NDFREE CALL STORSQ (NDFREE,MAXBAN,NFLUX,INDEX,S,SS) ELSE C SKYLINE MODE STOP 'add skystore influx' ENDIF ENDIF 30 CONTINUE C CLEAR ARRAY C AND S FOR LATER USE CALL ZEROA (NFLUX,C) CALL ZEROA (NFLUX*NFLUX,S) RETURN END SUBROUTINE INLTYP (NLTYPE, LTDATA, N, NQP, NGEOM, 1 NPARM, LSHAPE ) C * * * * * * * * * * * * * * * * * * * * * * * * * * * C SET OR READ ELEMENT TYPE DATA ITEMS C * * * * * * * * * * * * * * * * * * * * * * * * * * * PARAMETER ( NCRD =5, NPRT = 6 ) DIMENSION LTDATA(6,NLTYPE) C NLTYPE = NUMBER OF ELEMENT TYPES C LTN = NUMBER OF NODES PER ELEMENT C LTQP = NUMBER OF QUADRATURE POINTS C LGEOM = NUMBER OF ELEMENT GEOMERTY NODES C LTPARM = NUMBER OF PARAMETRIC SPACES FOR ELEMENT C LTSHAP = ELEMNET SHAPE FLAG NUMBER C LTUSER = APPLICATION DEPENDENT OPTIONAL USER ITEM IF ( NLTYPE .EQ. 1 ) THEN C DEFAULT IS SINGLE TYPE ONLY LTDATA(1,1) = N LTDATA(2,1) = NQP LTDATA(3,1) = NGEOM LTDATA(4,1) = NPARM LTDATA(5,1) = LSHAPE LTDATA(6,1) = 0 LT = 1 LTUSER = 0 WRITE (NPRT,5020) LT, N, NQP, NGEOM, NPARM, 1 LSHAPE, LTUSER ELSE C READ SEVERAL DIFFERENT TYPES DO 10 IT = 1, NLTYPE READ (NCRD,5000) LT, LTN, LTQP, LTGEOM, LTPARM, 1 LTSHAP, LTUSER 5000 FORMAT ( 7I5 ) IF ( LT .LT. 1 .OR. LT .GT. NLTYPE ) STOP 1 'ELEMENT TYPE WRONG, INLTYP' IF ( LTN .GT. N .OR. LTQP .GT. NQP .OR. 1 LTGEOM .GT. NGEOM .OR. LTPARM .GT. NPARM ) 2 STOP 'ELEMENT TYPE DATA EXCEEDS MAXIMUM, INLTYP' LTDATA(1,LT) = LTN LTDATA(2,LT) = LTQP LTDATA(3,LT) = LTGEOM LTDATA(4,LT) = LTPARM LTDATA(5,LT) = LTSHAP LTDATA(6,LT) = LTUSER WRITE (NPRT,5020) LT, LTN, LTQP, LTGEOM, LTPARM, 1 LTSHAP, LTUSER 5020 FORMAT ( /, 'ELEMENT TYPE NUMBER =', I3, /, 1 'NUMBER OF NODES PER ELEMENT ..........', I3, /, 2 'NUMBER OF QUADRATURE POINTS ..........', I3, /, 3 'NUMBER OF GEOMETRIC CONTROL NODES ....', I3, /, 4 'NUMBER OF PARAMETRIC DIMENSIONS ......', I3, /, 5 'ELEMENT SHAPE NUMBER . ...............', I3, /, 6 'APPLICATION DEPENDENT USER FLAG ......', I3) 10 CONTINUE ENDIF RETURN END SUBROUTINE INPROP (M, NE, NNPFIX, NNPFLO, NLPFIX, 1 NLPFLO, MISCFX, MISCFL, FLTNP, 2 FLTEL, FLTMIS, NPFIX, LPFIX, 3 MISFIX, NHOMO, LHOMO, NBSFIX, 4 NBSFLO, NBSPFX, FLTBS, NBS) C * * * * * * * * * * * * * * * * * * * * * * * * * * C INPUT NODAL POINT, ELEMENT, AND MISCELLANEOUS C SYSTEM PROPERTIES C * * * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8(A-H,O-Z) PARAMETER ( NCRD = 5, NPRT = 6 ) DIMENSION FLTNP(M,0:NNPFLO), FLTEL(NE,0:NLPFLO), 1 FLTMIS(0:MISCFL), FLTBS(0:NBS,0:NBSFLO), 2 MISFIX(0:MISCFX), NPFIX(M,0:NNPFIX), 3 LPFIX(NE,0:NLPFIX), NBSPFX(0:NBS,0:NBSFIX) C M = NUMBER OF SYSTEM NODES C NBS = NUMBER OF BOUNDARY SEGMENTS WITH FLUX C NE = NUMBER OF ELEMENTS IN SYSTEM C FLTNP, FLTEL, FLTMIS, FLTBS = REAL PROPERTIES OF c SYSTEM NODES, ELEMENTS, SEGMENTS, AND MISC. C NPFIX, LPFIX, MISFIX, NBSFIX = INTEGER PROPERTIES OF C SYSTEM NODES, ELEMENTS, SEGMENTS, AND MISC. C LHOMO = 1, IF ALL ELEMENTS & SEGMENTS SAME AS FIRST C NHOMO = 1, IF ALL NODES SAME AS FIRST ONE C NBSFLO = NUMBER OF REAL SEGMENT PROPERTIES C NNPFLO = NUMBER OF REAL NODAL PROPERTIES C NBSFIX = NUMBER OF INTEGER SEGMENT PROPERTIES C NNPFIX = NUMBER OF INTEGER NODAL PROPERTIES C NLPFIX = NUMBER OF INTEGER ELEMENT PROPERTIES C MISCFL = NUMBER OF MISC. REAL SYSTEM PROPERTIES C MISCFX = NUMBER OF MISC. INTEGER SYSTEM PROPERTIES IF ( NNPFIX .GT. 0 .OR. NNPFLO .GT. 0 ) THEN C--> READ NODAL POINT PROPERTIES WRITE (NPRT,5000) 5000 FORMAT ( /, '*** NODAL POINT PROPERTIES ***',/, 1 ' NODE PROPERTY VALUE') MAX = M IF ( NHOMO .EQ. 1 ) MAX = 1 IF ( NNPFIX .GT. 0 ) THEN DO 10 I = 1, MAX READ (NCRD,5010) J, (NPFIX(J,K), K=1,NNPFIX) 5010 FORMAT ( I10, (7I10) ) IF ( J .GE. M ) GO TO 20 10 CONTINUE C ECHO INPUT 20 WRITE (NPRT,5030) ( (J, K, NPFIX(J,K), J = 1, MAX), 1 K = 1, NNPFIX ) 5030 FORMAT (I10, I10, 3X, I10) WRITE (NPRT,*) 'END INTEGER PROPERTIES OF NODES' WRITE (NPRT,*) ' ' ENDIF IF ( NNPFLO .GT. 0 ) THEN DO 40 I = 1, MAX READ (NCRD,5050) J, (FLTNP(J,K), K = 1,NNPFLO) 5050 FORMAT ( I10, 7F10.4, (/, 8F10.4) ) c5050 FORMAT ( I10, (7F10.4) ) IF ( J .GE. M ) GO TO 50 40 CONTINUE C ECHO INPUT 50 WRITE (NPRT,5060) ( (J, K, FLTNP(J,K), J = 1, MAX), 1 K = 1, NNPFLO ) 5060 FORMAT (I10, I10, 3X, 1PE12.5) WRITE (NPRT,*) 'END OF REAL PROPERTIES OF NODES' WRITE (NPRT,*) ' ' ENDIF ENDIF IF ( NLPFIX .GT. 0 .OR. NLPFLO .GT. 0 ) THEN C--> READ ELEMENT PROPERTIES WRITE (NPRT,5080) 5080 FORMAT ( /, '*** ELEMENT PROPERTIES ***',/, 1 'ELEMENT PROPERTY VALUE') MAX = NE IF ( LHOMO .EQ. 1 ) MAX = 1 IF ( NLPFIX .GT. 0 ) THEN DO 70 I = 1, MAX READ (NCRD,5010) J, (LPFIX(J,K), K=1,NLPFIX) IF ( J .GE. NE ) GO TO 80 70 CONTINUE C ECHO 80 WRITE (NPRT,5030) ( (J, K, LPFIX(J,K), J = 1,MAX), 1 K = 1, NLPFIX ) WRITE (NPRT,*) 'END INTEGER PROPERTIES OF ELEMENTS' WRITE (NPRT,*) ' ' ENDIF IF ( NLPFLO .GT. 0 ) THEN DO 100 I = 1, MAX READ (NCRD,5050) J, (FLTEL(J,K), K=1,NLPFLO) IF ( J .GE. NE ) GO TO 110 100 CONTINUE 110 WRITE (NPRT,5060) ( (J, K, FLTEL(J,K), J=1,MAX), 1 K = 1,NLPFLO ) WRITE (NPRT,*) 'END REAL PROPERTIES OF ELEMENTS' WRITE (NPRT,*) ' ' ENDIF ENDIF IF ( NBSFIX .GT. 0 .OR. NBSFLO .GT. 0 ) THEN C--> READ SEGMENT PROPERTIES WRITE (NPRT,5085) 5085 FORMAT ( /, '*** SEGMENT PROPERTIES ***',/, 1 'SEGMENT PROPERTY VALUE') MAX = NBS IF ( LHOMO .EQ. 1 ) MAX = 1 IF ( NBSFIX .GT. 0 ) THEN DO 75 I = 1, MAX READ (NCRD,5010) J, (NBSPFX(J,K), K=1,NBSFIX) IF ( J .GE. NBS ) GO TO 85 75 CONTINUE C ECHO 85 WRITE (NPRT,5030) ( (J, K, NBSPFX(J,K), J = 1,MAX), 1 K = 1, NBSFIX ) WRITE (NPRT,*) 'END INTEGER PROPERTIES OF SEGMENTS' WRITE (NPRT,*) ' ' ENDIF IF ( NBSFLO .GT. 0 ) THEN DO 105 I = 1, MAX READ (NCRD,5050) J, (FLTBS(J,K), K=1,NBSFLO) IF ( J .GE. NBS ) GO TO 115 105 CONTINUE 115 WRITE (NPRT,5060) ( (J, K, FLTBS(J,K), J=1,MAX), 1 K = 1,NBSFLO ) WRITE (NPRT,*) 'END REAL PROPERTIES OF SEGMENTS' WRITE (NPRT,*) ' ' ENDIF ENDIF IF ( MISCFX .GT. 0 .OR. MISCFL .GT. 0 ) THEN C--> READ MISC. SYSTEM PROPERTIES WRITE (NPRT,5120) 5120 FORMAT ( /, '*** MISCELLANEOUS SYSTEM PROPERTIES', 1 ' ***',/, 'PROPERTY VALUE') IF ( MISCFX .GT. 0 ) THEN READ (NCRD,5130) (MISFIX(K), K=1,MISCFX) 5130 FORMAT ( (8I10) ) C ECHO DO 130 K = 1,MISCFX WRITE (NPRT,5140) K, MISFIX(K) 5140 FORMAT ( I8, 3X, I10 ) 130 CONTINUE WRITE (NPRT,*) 'END OF INTEGER PROPERTIES OF SYSTEM' ENDIF IF ( MISCFL .GT. 0 ) THEN READ (NCRD,5160) (FLTMIS(K), K=1,MISCFL) 5160 FORMAT ( (8F10.4) ) DO 140 K=1,MISCFL WRITE (NPRT,5170) K,FLTMIS(K) 5170 FORMAT ( I8, 3X, 1PE13.5 ) 140 CONTINUE ENDIF WRITE (NPRT,*) 'END REAL PROPERTIES OF SYSTEM' ENDIF c call at(59) RETURN END SUBROUTINE INPUT (M, N, NE, NG, NSPACE, X, IBC, NODES) C * * * * * * * * * * * * * * * * * * * * * * * * * * C READ BASIC PROBLEM DATA C * * * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8 (A-H,O-Z) PARAMETER ( NCRD = 5, NPRT = 6 , NBUG = 6 ) DIMENSION X(M,NSPACE), IBC(M), NODES(NE,N) C M = NUMBER OF NODES IN SYSTEM C N = NUMBER OF NODES PER ELEMENT C NE = NUMBER OF ELEMENTS IN SYSTEM C NG = NUMBER OF PARAMETERS (DOF) PER NODE C NSPACE = DIMENSION OF SOLUTION SPACE C X = SYSTEM COORDINATES OF ALL NODES C IBC = PACKED NODAL CONSTRAINT INDICATOR C NODES = SYSTEM ARRAY OF ELEMENT INCIDENCES C--> READ NODAL POINT DATA WRITE (NPRT,5000) NSPACE 5000 FORMAT ( /, '*** NODAL POINT DATA ***',/, 1 'NODE, CONSTRAINT FLAG,',I2,' COORDINATES') DO 10 I = 1, M READ (NCRD,5010) J, IBC(J), (X(J,K), K=1,NSPACE) WRITE (NPRT,5010) J, IBC(J), (X(J,K), K=1,NSPACE) 5010 FORMAT ( 2I10, (6F10.4) ) IF ( J .GT. M ) WRITE (NBUG,*) 'INVALID NODE, INPUT' 10 CONTINUE C--> READ ELEMENT DATA WRITE (NPRT,5030) N 5030 FORMAT ( /, '*** ELEMENT CONNECTIVITY DATA ***',/, 1 'ELEMENT NO., ', I2 ,' NODAL INCIDENCES.') DO 20 I = 1, NE READ (NCRD,5050) J, (NODES(J,K), K=1,N) WRITE (NPRT,5050) J, (NODES(J,K), K=1,N) 5050 FORMAT ( I5, (15I5) ) IF ( J .GT. NE ) WRITE (NBUG,*) 'INVALID ELEMENT, INPUT' 20 CONTINUE RETURN END SUBROUTINE INVDET (AJ, AJINV, DET, NSPACE) C * * * * * * * * * * * * * * * * * * * * * * * * * * C FIND INVERSE AND DETERMINATE OF JACOBIAN C * * * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8 (A-H,O-Z) DIMENSION AJ(NSPACE,NSPACE), AJINV(NSPACE,NSPACE) C NSPACE = NUMBER OF SPATIAL DIMENSIONS C AJ = JACOBIAN MATRIX AT A POINT C AJINV = INVERSE OF AJ C DET = DETERMINATE OF AJ C--> 1-D IF ( NSPACE .EQ. 1 ) THEN DET = AJ(1,1) IF ( DET .NE. 0.0 ) THEN AJINV(1,1) = 1.0/DET ELSE STOP 'BAD DET, INVDET' ENDIF RETURN ENDIF C--> 2-D IF ( NSPACE .EQ. 2 ) THEN CALL I2BY2 (AJ,AJINV,DET) RETURN ENDIF C--> 3-D IF ( NSPACE .EQ. 3 ) THEN CALL I3BY3 (AJ,AJINV,DET) RETURN ENDIF STOP 'BAD NSPACE, INVDET' END SUBROUTINE INVECT (NDFREE, NG, CC, M, TOTAL) C * * * * * * * * * * * * * * * * * * * * * * * * * * C INPUT SPECIFIED VALUES IN FORCING VECTOR, CC C * * * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8(A-H,O-Z) PARAMETER ( NCRD = 5, NPRT = 6 ) DIMENSION CC(NDFREE), TOTAL(NG) C NDFREE = TOTAL NUMBER OF SYSTEM DEGREES OF FREEDOM C NG = NUMBER OF PARAMETERS PER NODE C CC = SYSTEM EQUATIONS COLUMN MATRIX C M = TOTAL NUMBER OF NODES IN THE SYSTEM DO 5 I = 1, NG 5 TOTAL(I) = 0.0 WRITE (NPRT,5000) 5000 FORMAT ( /, '*** INITIAL FORCING VECTOR DATA ***',/, 1' NODE PARAMETER VALUE EQUATION') DO 10 I = 1, NDFREE READ (NCRD,5010) NODE, IPARM, VALUE 5010 FORMAT ( 2I10, F15.4 ) C FIND CORRESPONDING DEGREE OF FREEDOM NUMBER CALL DEGPAR (NODE,IPARM,NG,J) CC(J) = VALUE TOTAL(IPARM) = TOTAL(IPARM) + VALUE C LIST INPUT DATA WRITE (NPRT,5020) NODE, IPARM, VALUE, J 5020 FORMAT ( 2I10, 1X, 1PE13.5, I8) IF ( NODE .GT. M .OR. IPARM .GT. NG ) 1 STOP 'NODE OR IPARM DATA ERROR, INVECT' IF ( J .EQ. NDFREE ) GO TO 20 10 CONTINUE 20 WRITE (6,5030) 5030 FORMAT ('*RESULTANTS*',/, 1 'DOF SUM') DO 40 J = 1, NG 40 WRITE (6,5040) J, TOTAL(J) 5040 FORMAT ( I3, 2X, 1PE12.4 ) RETURN END SUBROUTINE INVERT (N, A, B, C) C * * * * * * * * * * * * * * * * * * * * * * * * * * C INVERSION OF NONSYMMETRIC MATRIX A(N,N) C * * * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8 (A-H,O-Z) DIMENSION A(N,N), B(N), C(N) C A IS DESTROYED AND REPLACED BY ITS INVERSE C B,C = ARE WORKING SPACE VECTORS C N = SIZE OF GIVEN MATRIX NN = N - 1 IF ( A(1,1) .EQ. 0.0 ) STOP 'ZERO PIVOT IN INVERT' A(1,1) = 1./A(1,1) DO 11 M = 1, NN K = M + 1 1 DO 3 I = 1, M B(I) = 0. DO 2 J = 1, M 2 B(I) = B(I) + A(I,J)*A(J,K) 3 CONTINUE D = 0.0 DO 4 I = 1, M 4 D = D + A(K,I)*B(I) D = -D + A(K,K) IF ( D .EQ. 0.0 ) STOP 'ZERO PIVOT IN INVERT' A(K,K) = 1./D DO 5 I = 1, M 5 A(I,K) = -B(I)*A(K,K) DO 7 J = 1, M C(J) = 0. DO 6 I = 1, M 6 C(J) = C(J) + A(K,I)*A(I,J) 7 CONTINUE DO 8 J = 1, M 8 A(K,J) = -C(J)*A(K,K) DO 10 I = 1, M DO 9 J = 1, M 9 A(I,J) = A(I,J)-B(I)*A(K,J) 10 CONTINUE 11 CONTINUE RETURN END SUBROUTINE IPRINT (M, NR, NC) C * * * * * * * * * * * * * * * * * * * * * * * C PRINTING OF AN INTEGER ARRAY M(NR,NC) C * * * * * * * * * * * * * * * * * * * * * * * PARAMETER ( NPRT = 6, MAX = 10 ) DIMENSION M(1), NCOL(MAX) DO 30 J = 1,NC,MAX JL1 = J - 1 MAXCOL = 1 K = NC - JL1 MAXCOL = MIN0 (K,MAX) MXCLL1 = MAXCOL - 1 DO 10 L = 1,MAXCOL 10 NCOL(L) = L + JL1 WRITE (NPRT,5000) ( NCOL(N),N=1,MAXCOL ) 5000 FORMAT ('ROW/COL',I7, 9I10 ) DO 20 N = 1,NR NL = N + (J-1)*NR NH = NL + MXCLL1*NR WRITE (NPRT,5010) N,( M(I),I=NL,NH,NR ) 5010 FORMAT ( I4, 10I10 ) 20 CONTINUE 30 CONTINUE RETURN END SUBROUTINE IREMRK (ISAY) C * * * * * * * * * * * * * * * * * * * * * * * * * * C READ AND PRINT ISAY CARDS FOR USER REMARKS C * * * * * * * * * * * * * * * * * * * * * * * * * * cb DIMENSION REMARK(20) CHARACTER*4 REMARK(20) WRITE (6,*) ' ' WRITE (6,*) 'NEXT ', ISAY,' LINES ARE USER SUPPLIED' DO 10 I = 1,ISAY READ (5,5010) REMARK WRITE (6,5010) REMARK 5010 FORMAT (20A4) 10 CONTINUE WRITE (6,*) ' ' RETURN END SUBROUTINE ISOPAR (N, NSPACE, NELFRE, NIP, SQ, COL, 1 QPT, QWT, H, DLH, DGH, COORD, 2 XPT, AJ, AJINV, NTAPE1, NGRAND, 3 LSHAPE, NG, LNODE, IE) C * * * * * * * * * * * * * * * * * * * * * * * * * * * C NUMERICAL INTEGRATION IN AN ISOPARAMETRIC ELEMENT C * * * * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8 (A-H,O-Z) CDP ABS(Z) = DABS(Z) EXTERNAL NGRAND PARAMETER ( ZERO = 0.0 ) cb 1 QPT(NSPACE,0:NIP), H(N), DLH(NSPACE,N), cb 2 DGH(NSPACE,N), COORD(N,NSPACE), XPT(NSPACE), DIMENSION COL(NELFRE), SQ(NELFRE,NELFRE), QWT(0:NIP), 1 QPT(NSPACE,0:NIP), H(nelfre), DLH(NSPACE,nelfre), 2 DGH(NSPACE,nelfre), COORD(N,NSPACE), XPT(NSPACE), 3 AJ(NSPACE,NSPACE), AJINV(NSPACE,NSPACE), LNODE(N) C c23456789012345678901234567890123456789012345678901234567890-----------X C IE = ELEMENT NUMBER C N = NUMBER OF NODES PER ELEMENT C NSPACE = NUMBER OF SPATIAL DIMENSIONS C NELFRE = NUMBER OF ELEMENT DEGREES OF FREEDOM C NIP = NUMBER OF INTEGRATION POINTS C QPT = QUADRATURE PT COORDS C QWT = QUADRATURE PT WEIGHT C SQ = PROB DEPENDENT SQ MATRIX C COL = PROB DEPENDENT COLUMN MATRIX C H = ELEMENT INTERPOLATION FUNCTIONS C DLH = LOCAL DERIVATIVES OF H C DGH = GLOBAL DERIVATIVES OF H C COORD = GLOBAL COORD OF NODES OF ELEMENT C XPT = GLOBAL COORD OF QUADRATURE POINT C AJ = JACOBIAN MATRIX C AJINV = JACOBIAN INVERSE C DET = JACOBIAN DETERMINANT C NTAPE1 = STORAGE UNIT FOR POST SOLUTION DATA C NGRAND = 'EXTERNAL' PROB DEP INTEGRAND ROUTINE C--> ZERO INTEGRANDS CALL ZEROA (NELFRE,COL) CALL ZEROA (NELFRE*NELFRE,SQ) C--> BEGIN INTEGRATION IWARN = 0 c write(6,*) 'isopar' c call rprint(qpt,nspace,nip+1,0) c call rprint(qwt,1,nip+1,0) DO 100 IP = 1, NIP C EVALUATE INTERPOLATION FUNCTIONS CALL ESHAPE (QPT(1,IP), H, N, NSPACE, LSHAPE, NG, LNODE) C FIND GLOBAL COORD, XPT = H*COORD CALL MMULT (H, COORD, XPT, 1, N,NSPACE) C FIND LOCAL DERIVATIVES CALL DERIV (QPT(1,IP), DLH, N, NSPACE, LSHAPE, NG, LNODE) C FIND JACOBIAN AT THE PT CALL JACOB (N, NSPACE, DLH, COORD, AJ) C FORM INVERSE AND DETERMINATE OF JACOBIAN CALL INVDET (AJ, AJINV, DET, NSPACE) IF ( DET .LT. ZERO ) THEN IWARN = IWARN + 1 DET = ABS( DET ) ENDIF C EVALUATE GLOBAL DERIVATIVES CALL GDERIV (NSPACE, N, AJINV, DLH, DGH) c if ( ip .eq. 1 ) then c call rprint(dgh, nspace, n, 0) c call rprint(dlh, nspace, n, 0) c call rprint(h, 1, n, 0) c write(6, *) det, qwt c endif C *** FORM PROBLEM DEPENDENT INTEGRANDS *** CALL NGRAND (QWT(IP), DET, H, DGH, XPT, N, 1 NSPACE, NELFRE, COL, SQ, NTAPE1) 100 CONTINUE IF ( IWARN .GT. 0 ) WRITE (6,*) 1 'WARNING, NEGATIVE JACOBIAN CORRECTED, IE =', IE RETURN END SUBROUTINE JACOB (N, NSPACE, DELTA, COORD, AJ) C * * * * * * * * * * * * * * * * * * * * * * * * * * C CALCULATE THE JACOBIAN MATRIX AT A LOCAL POINT C * * * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8 (A-H,O-Z) DIMENSION DELTA(NSPACE,N), COORD(N,NSPACE), 1 AJ(NSPACE,NSPACE) C N = NUMBER OF NODES PER ELEMENT C NSPACE = DIMENSION OF SPACE C DELTA = LOCAL DERIVATIVES OF N INTERPOLATION C FUNCTIONS AT POINT OF INTEREST. C COORD = SPATIAL COORDINATES OF ELEMENT'S NODES C AJ = JACOBIAN MATRIX = DELTA*COORD DO 30 I = 1, NSPACE DO 20 J = 1, NSPACE SUM = 0.0 DO 10 K = 1, N SUM = SUM + DELTA(I,K)*COORD(K,J) 10 CONTINUE AJ(I,J) = SUM 20 CONTINUE 30 CONTINUE RETURN END SUBROUTINE KQRULE (IDEG, NQP, NCORD, PT, WT) c still being debugged from dqrule, may 1 95 C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C KEAST QUADRATURE RULE FOR TETRAHEDRA, TO DEGREE = 8 C IN VOLUME COORDINATES (NCORD=4), OR UNIT COORDINATES (NCORD=3) C C.M.A.M.E. VOL. 55, PP. 339-348, 1986 C INPUT IDEG=0,1,2,3, 4, 5, 6, 7, 8, NQP=0 C OR NQP=1,1,4,5,11,16,24,31,45 C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C WARNING: REQUIRES COMPILER FLAG FOR 40 CONTINUATION LINES,-Nl40 <===== CDP IMPLICIT REAL*8 (A-H,O,R-V,X-Z) C PT & WT ARE SINGLE PRECISION PARAMETER ( MAXDEG = 17, MAXDAT = 107 ) DIMENSION PT(NCORD,0:*), WT(0:*) DIMENSION VW(MAXDAT), A1(MAXDAT), A2(MAXDAT), A3(MAXDAT), 1 A4(MAXDAT), NQPDEG(MAXDEG), ISTART(MAXDEG), 2 LINES(MAXDEG), KOUNTS(MAXDAT) C IDEG = DEGREE OF POLYNOMIAL TO BE INTEGRATED, 0 TO MAXDEG C NQP = NUMBER OF QUADRATURE POINTS, USE 0 IF IDEG GOVERNS C NCORD = NUMBER OF PARAMETRIC DIMENSIONS: 4-VOL, 3-UNIT CORD C PT = RETURNED QUADRATURE COORDINATES, PT(NCORD,NQP) C WT = RETURNED QUADRATURE WEIGHTS, WT(NQP) C C NQPDEG = NUMBER QUADRATURE PTS FOR POLYNOMIAL DEGREE C ISTART = WHERE IDEG RULE DATA STARTS IN DATA TABLES C LINES = NUMBER OF LINES OF DATA FOR EACH RULE C KOUNTS = NUMBER OF TIMES THAT A RULE LINE IS USED C A1--A4 = VOLUME COORDINATES OF TABLE POINT C VW = VOLUME WEIGHT OF TABLE POINT DATA NQPDEG /1,3,4,6,7,12,13,16,19,25,27,33,37,42,48,52,61/ DATA LINES /1,1,2,2,3, 3, 4, 5, 6, 6, 7, 8,10,10,11,13,15/ DATA ISTART /1,2,3,5,7,10,13,17,22,28,34,41,49,59,69,80,93/ DATA KOUNTS /1,3,1,3,3,3,1,3,3,3,3,6,1,3,3,6,1,3,3,3,6,1,3,3,3, 1 3,6,1,3,3,6,6,6,3,3,3,3,3,6,6,3,3,3,3,3,6,6,6,1,3, 2 3,3,3,3,3,6,6,6,3,3,3,3,3,3,6,6,6,6,3,3,3,3,3,3,6, 3 6,6,6,6,1,3,3,3,3,3,3,3,6,6,6,6,6,1,3,3,3,3,3,3,3, 4 3,6,6,6,6,6,6 / DATA VW / + 1.000000000000000, 0.333333333333333, -0.562500000000000, + 0.520833333333333, 0.223381589678011, 0.109951743655322, + 0.225000000000000, 0.132394152788506, 0.125939180544827, + 0.116786275726379, 0.050844906370207, 0.082851075618374, + -0.149570044467682, 0.175615257433208, 0.053347235608838, + 0.077113760890257, 0.144315607677787, 0.095091634267285, + 0.103217370534718, 0.032458497623198, 0.027230314174435, + 0.097135796282799, 0.031334700227139, 0.077827541004774, + 0.079647738927210, 0.025577675658698, 0.043283539377289, + 0.090817990382754, 0.036725957756467, 0.045321059435528, + 0.072757916845420, 0.028327242531057, 0.009421666963733, + 0.000927006328961, 0.077149534914813, 0.059322977380774, + 0.036184540503418, 0.013659731002678, 0.052337111962204, + 0.020707659639141, 0.025731066440455, 0.043692544538038, + 0.062858224217885, 0.034796112930709, 0.006166261051559, + 0.040371557766381, 0.022356773202303, 0.017316231108659, + 0.052520923400802, 0.011280145209330, 0.031423518362454, + 0.047072502504194, 0.047363586536355, 0.031167529045794, + 0.007975771465074, 0.036848402728732, 0.017401463303822, + 0.015521786839045, 0.021883581369429, 0.032788353544125, + 0.051774104507292, 0.042162588736993, 0.014433699669777, + 0.004923403602400, 0.024665753212564, 0.038571510787061, + 0.014436308113534, 0.005010228838501, 0.001916875642849, + 0.044249027271145, 0.051186548718852, 0.023687735870688, + 0.013289775690021, 0.004748916608192, 0.038550072599593, + 0.027215814320624, 0.002182077366797, 0.021505319847731, + 0.007673942631049, 0.046875697427642, 0.006405878578585, + 0.041710296739387, 0.026891484250064, 0.042132522761650, + 0.030000266842773, 0.014200098925024, 0.003582462351273, + 0.032773147460627, 0.015298306248441, 0.002386244192839, + 0.019084792755899, 0.006850054546542, 0.033437199290803, + 0.005093415440507, 0.014670864527638, 0.024350878353672, + 0.031107550868969, 0.031257111218620, 0.024815654339665, + 0.014056073070557, 0.003194676173779, 0.008119655318993, + 0.026805742283163, 0.018459993210822, 0.008476868534328, + 0.018292796770025, 0.006665632004165 / DATA A1 / + 0.333333333333333, 0.666666666666667, 0.333333333333333, + 0.600000000000000, 0.108103018168070, 0.816847572980459, + 0.333333333333333, 0.059715871789770, 0.797426985353087, + 0.501426509658179, 0.873821971016996, 0.053145049844817, + 0.333333333333333, 0.479308067841920, 0.869739794195568, + 0.048690315425316, 0.333333333333333, 0.081414823414554, + 0.658861384496480, 0.898905543365938, 0.008394777409958, + 0.333333333333333, 0.020634961602525, 0.125820817014127, + 0.623592928761935, 0.910540973211095, 0.036838412054736, + 0.333333333333333, 0.028844733232685, 0.781036849029926, + 0.141707219414880, 0.025003534762686, 0.009540815400299, + -0.069222096541517, 0.202061394068290, 0.593380199137435, + 0.761298175434837, 0.935270103777448, 0.050178138310495, + 0.021022016536166, 0.023565220452390, 0.120551215411079, + 0.457579229975768, 0.744847708916828, 0.957365299093579, + 0.115343494534698, 0.022838332222257, 0.025734050548330, + 0.333333333333333, 0.009903630120591, 0.062566729780852, + 0.170957326397447, 0.541200855914337, 0.771151009607340, + 0.950377217273082, 0.094853828379579, 0.018100773278807, + 0.022233076674090, 0.022072179275643, 0.164710561319092, + 0.453044943382323, 0.645588935174913, 0.876400233818255, + 0.961218077502598, 0.057124757403648, 0.092916249356972, + 0.014646950055654, 0.001268330932872, -0.013945833716486, + 0.137187291433955, 0.444612710305711, 0.747070217917492, + 0.858383228050628, 0.962069659517853, 0.133734161966621, + 0.036366677396917, -0.010174883126571, 0.036843869875878, + 0.012459809331199, 0.333333333333333, 0.005238916103123, + 0.173061122901295, 0.059082801866017, 0.518892500060958, + 0.704068411554854, 0.849069624685052, 0.966807194753950, + 0.103575692245252, 0.020083411655416, -0.004341002614139, + 0.041941786468010, 0.014317320230681, 0.333333333333333, + 0.005658918886452, 0.035647354750751, 0.099520061958437, + 0.199467521245206, 0.495717464058095, 0.675905990683077, + 0.848248235478508, 0.968690546064356, 0.010186928826919, + 0.135440871671036, 0.054423924290583, 0.012868560833637, + 0.067165782413524, 0.014663182224828 / DATA A2 / + 0.333333333333333, 0.166666666666667, 0.333333333333333, + 0.200000000000000, 0.445948490915965, 0.091576213509771, + 0.333333333333333, 0.470142064105115, 0.101286507323456, + 0.249286745170910, 0.063089014491502, 0.310352451033784, + 0.333333333333333, 0.260345966079040, 0.065130102902216, + 0.312865496004874, 0.333333333333333, 0.459292588292723, + 0.170569307751760, 0.050547228317031, 0.263112829634638, + 0.333333333333333, 0.489682519198738, 0.437089591492937, + 0.188203535619033, 0.044729513394453, 0.221962989160766, + 0.333333333333333, 0.485577633383657, 0.109481575485037, + 0.307939838764121, 0.246672560639903, 0.066803251012200, + 0.534611048270758, 0.398969302965855, 0.203309900431282, + 0.119350912282581, 0.032364948111276, 0.356620648261293, + 0.171488980304042, 0.488217389773805, 0.439724392294460, + 0.271210385012116, 0.127576145541586, 0.021317350453210, + 0.275713269685514, 0.281325580989940, 0.116251915907597, + 0.333333333333333, 0.495048184939705, 0.468716635109574, + 0.414521336801277, 0.229399572042831, 0.114424495196330, + 0.024811391363459, 0.268794997058761, 0.291730066734288, + 0.126357385491669, 0.488963910362179, 0.417644719340454, + 0.273477528308839, 0.177205532412543, 0.061799883090873, + 0.019390961248701, 0.172266687821356, 0.336861459796345, + 0.298372882136258, 0.118974497696957, 0.506972916858243, + 0.431406354283023, 0.277693644847144, 0.126464891041254, + 0.070808385974686, 0.018965170241073, 0.261311371140087, + 0.388046767090269, 0.285712220049916, 0.215599664072284, + 0.103575616576386, 0.333333333333333, 0.497380541948438, + 0.413469438549352, 0.470458599066991, 0.240553749969521, + 0.147965794222573, 0.075465187657474, 0.016596402623025, + 0.296555596579887, 0.337723063403079, 0.204748281642812, + 0.189358492130623, 0.085283615682657, 0.333333333333333, + 0.497170540556774, 0.482176322624625, 0.450239969020782, + 0.400266239377397, 0.252141267970953, 0.162047004658461, + 0.075875882260746, 0.015654726967822, 0.334319867363658, + 0.292221537796944, 0.319574885423190, 0.190704224192292, + 0.180483211648746, 0.080711313679564 / DATA A3 / + 0.333333333333333, 0.166666666666667, 0.333333333333333, + 0.200000000000000, 0.445948490915965, 0.091576213509771, + 0.333333333333333, 0.470142064105115, 0.101286507323456, + 0.249286745170910, 0.063089014491502, 0.636502499121399, + 0.333333333333333, 0.260345966079040, 0.065130102902216, + 0.638444188569810, 0.333333333333333, 0.459292588292723, + 0.170569307751760, 0.050547228317031, 0.728492392955404, + 0.333333333333333, 0.489682519198738, 0.437089591492937, + 0.188203535619033, 0.044729513394453, 0.741198598784498, + 0.333333333333333, 0.485577633383657, 0.109481575485037, + 0.550352941820999, 0.728323904597411, 0.923655933587500, + 0.534611048270758, 0.398969302965855, 0.203309900431282, + 0.119350912282581, 0.032364948111276, 0.593201213428213, + 0.807489003159792, 0.488217389773805, 0.439724392294460, + 0.271210385012116, 0.127576145541586, 0.021317350453210, + 0.608943235779788, 0.695836086787803, 0.858014033544073, + 0.333333333333333, 0.495048184939705, 0.468716635109574, + 0.414521336801277, 0.229399572042831, 0.114424495196330, + 0.024811391363459, 0.636351174561660, 0.690169159986905, + 0.851409537834241, 0.488963910362179, 0.417644719340454, + 0.273477528308839, 0.177205532412543, 0.061799883090873, + 0.019390961248701, 0.770608554774996, 0.570222290846683, + 0.686980167808088, 0.879757171370171, 0.506972916858243, + 0.431406354283023, 0.277693644847144, 0.126464891041254, + 0.070808385974686, 0.018965170241073, 0.604954466893291, + 0.575586555512814, 0.724462663076655, 0.747556466051838, + 0.883964574092416, 0.333333333333333, 0.497380541948438, + 0.413469438549352, 0.470458599066991, 0.240553749969521, + 0.147965794222573, 0.075465187657474, 0.016596402623025, + 0.599868711174861, 0.642193524941505, 0.799592720971327, + 0.768699721401368, 0.900399064086661, 0.333333333333333, + 0.497170540556774, 0.482176322624625, 0.450239969020782, + 0.400266239377397, 0.252141267970953, 0.162047004658461, + 0.075875882260746, 0.015654726967822, 0.655493203809423, + 0.572337590532020, 0.626001190286228, 0.796427214974071, + 0.752351005937729, 0.904625504095608 / C CHECK FOR IDEG OR NQP CONTROL: LDEG = IDEG IF ( NQP .EQ. 0 ) THEN C USE DEGREE CONTROL IF ( IDEG .EQ. 0 ) NQP = 1 IF ( IDEG .LT. 0 .OR. IDEG .GT. MAXDEG ) THEN STOP 'INVALID IDEG ARGUMENT, DQRULE' ELSE NQP = NQPDEG(IDEG) ENDIF ELSE C USE NQP CONTROL LDEG = 0 DO 10 I = 1, MAXDEG IF ( NQP .EQ. NQPDEG(I) ) LDEG = I 10 CONTINUE IF ( LDEG .EQ. 0 ) STOP 'INVALID NQP ARGUMENT, DQRULE' ENDIF C FOUND VALID RULE, NOW EXPAND TABLE TO FULL RULE IPT = ISTART(LDEG) - 1 IRULE = 0 SUM = 0.D0 DO 20 I = 1, LINES(LDEG) J = IPT + I KOUNT = KOUNTS(J) IRULE = IRULE + 1 SUM = SUM + VW(J)*KOUNT WT(IRULE) = VW(J) PT(1,IRULE) = A1(J) PT(2,IRULE) = A2(J) IF ( NCORD .EQ. 3 ) PT(3,IRULE) = A3(J) IF ( KOUNT .GE. 3 ) THEN IRULE = IRULE + 1 WT(IRULE) = VW(J) PT(1,IRULE) = A3(J) PT(2,IRULE) = A1(J) IF ( NCORD .EQ. 3 ) PT(3,IRULE) = A2(J) IRULE = IRULE + 1 WT(IRULE) = VW(J) PT(1,IRULE) = A2(J) PT(2,IRULE) = A3(J) IF ( NCORD .EQ. 3 ) PT(3,IRULE) = A1(J) ENDIF IF ( KOUNT .EQ. 6 ) THEN IRULE = IRULE + 1 WT(IRULE) = VW(J) PT(1,IRULE) = A1(J) PT(2,IRULE) = A3(J) IF ( NCORD .EQ. 3 ) PT(3,IRULE) = A2(J) IRULE = IRULE + 1 WT(IRULE) = VW(J) PT(1,IRULE) = A3(J) PT(2,IRULE) = A2(J) IF ( NCORD .EQ. 3 ) PT(3,IRULE) = A1(J) IRULE = IRULE + 1 WT(IRULE) = VW(J) PT(1,IRULE) = A2(J) PT(2,IRULE) = A1(J) IF ( NCORD .EQ. 3 ) PT(3,IRULE) = A3(J) ENDIF 20 CONTINUE C CHECK VALIDITY OF RESULTS C IF ( SUM .NE. 1.D0 ) WRITE (6,*) C 1 'WARNING, UNITY NOT', SUM,', DQRULE' IF ( NCORD .EQ. 2 ) THEN DO 30 I = 1, NQP WT(I) = WT(I)*0.5D0 30 CONTINUE ENDIF RETURN END SUBROUTINE LAME (NPARM, NSPACE, GRAD, RE, F, RG, H) C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C GET THE LAME PARAMETERS, E F G AND H, AT PT C ON PARAMETRIC CURVE OR SURFACE C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8 (A-H,O-Z) DIMENSION GRAD(NPARM, NSPACE) C N = NUMBER OF NODES PER ELEMENT C NPARM = NUMBER OF PARAMETRIC DIMENSIONS <= NSPACE C NSPACE = DIMENSION OF PHYSICAL SPACE C DELTA = LOCAL DERIVATIVES OF N INTERPOLATION C FUNCTIONS AT POINT OF INTEREST. C COORD = SPATIAL COORDINATES OF ELEMENT'S NODES C GRAD = TANGENT MATRIX FROM TANVEC C FOR NPARM = NSPACE, GRAD = JACOBIAN C RE = SQUARE ROOT OF E, E = X,R^2 + Y,R^2 + Z,R^2 C RF = SQUARE ROOT OF F, F = X,S*X,R + Y,S*Y,R + Z,S*Z,R C RG = SQUARE ROOT OF G, G = X,S^2 + Y,S^2 + Z,S^2 IF ( NPARM .GT. 2 ) STOP 'INVALID ARGUMENT, LAME' G = 0. F = 0. E = GRAD(1,1)**2 IF ( NSPACE .GT. 1 ) E = E + GRAD(1,2)**2 IF ( NSPACE .EQ. 3 ) E = E + GRAD(1,3)**2 IF ( NPARM .GT. 1 ) THEN G = GRAD(2,1)**2 + GRAD(2,2)**2 IF ( NSPACE .EQ. 3 ) G = G + GRAD(2,3)**2 F = GRAD(1,1)*GRAD(2,1) + GRAD(1,2)*GRAD(2,2) IF ( NSPACE .EQ. 3 ) F = F + GRAD(1,3)*GRAD(2,3) ENDIF H = SQRT ( E*G - F*F ) RG = SQRT (G) RE = SQRT (E) RETURN END SUBROUTINE LASTL (M, N, NE, NODES, LNODE, LFIRST, 1 LLAST, IWARN) C * * * * * * * * * * * * * * * * * * * * * * * * * * * * C FIND ELEMENT OF FIRST & LAST APPEARANCE OF EACH NODE C ( VECTOR VERSION IN LASTLV ) C * * * * * * * * * * * * * * * * * * * * * * * * * * * * DIMENSION NODES(NE,N), LNODE(N), LFIRST(M), LLAST(M) C M = TOTAL NUMBER OF NODES IN SYSTEM C N = NUMBER OF NODES PER ELEMENT C NE = NUMBER OF ELEMENTS IN THE SYSTEM C NODES = SYSTEN ARRAY OF ALL ELEMENT INCIDENCES C LNODE = INCIDENCES ARRAY OF A SINGLE ELEMENT C LFIRST(I) = ELEMENT OF FIRST APPEARANCE OF NODE I C LLAST(I) = ELEMENT OF LAST APPEARANCE OF NODE I C IF IWARN.NE.0 WARN OF NODES WITH NO ELEMENTS DO 10 I = 1, M LFIRST(I) = 0 10 LLAST(I) = 0 DO 30 J = 1, NE C EXTRACT ELEMENT'S NODES CALL LNODES (J, NE, N, NODES, LNODE) C SCAN THE NODES DO 20 I = 1, N L = LNODE(I) IF ( L .LT. 1 ) GO TO 20 IF ( LFIRST(L) .EQ. 0 ) LFIRST(L) = J LLAST(L) = J 20 CONTINUE 30 CONTINUE IF ( IWARN .EQ. 0 ) RETURN C WARN OF NODES WITH NO ELEMENT CONNECTIONS DO 40 I = 1, M IF ( LFIRST(I) .GT. 0 ) GO TO 40 WRITE (6, 5000) I 5000 FORMAT ('WARNING, NODE ', I4, ' DOES NOT OCCUR IN ', 1 'THE ELEMENT INCIDENCES LIST') 40 CONTINUE RETURN END SUBROUTINE LCONTR (RINOUT, SINOUT, V, COORD, XYZ, N, 1 NSPACE, KOUNT, H, DH, LTYPE ) C * * * * * * * * * * * * * * * * * * * * * * * * * * C CALCULATE COORDINATES OF POINTS ON A CONTOUR C ON AN ISOPARAMETRIC SURFACE C * * * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8 (A-H,O-Z) PARAMETER ( MAX = 300, TRYDL = 0.005 ) DIMENSION COORD(N,NSPACE), V(N), H(N), DH(2,N), 1 PXYZ(3), XYZ(MAX,NSPACE), R(MAX), S(MAX), DER(2) EQUIVALENCE (PXYZ(1),DER(1),DVDR), (DER(2),DVDS) C MAX = MAX. NO. CONTOUR POINTS C DL = LOCAL COORD. LENGTH OF EACH SEGMENT C KOUNT = NO. OF PTS. ON CONTOUR CURVE C R,S = LOCAL COORDINATES C XYZ = GLOBAL COORD. ARRAY FOR COUNTOUR PTS. C PXYZ = GLOBAL COORDINATES OF A SINGLE POINT C COORD = GLOBAL COORD. OF NODES OF ELEMENT C N = NUMBER OF NODES PER ELEMENT C NSPACE = DIMENSION OF GLOBAL SPACE, 2 OR 3 C RINOUT,SINOUT = COORD OF 1ST (IN) OR LAST (OUT) PT C H = ELEMENT INTERPOLATION FUNCTIONS C DH = LOCAL COORD. DERIVATIVES OF H C V = NODAL VALUES OF QUANTITY TO BE CONTOURED C LTYPE = ELEM. TYPE, 0=QUADRILATERAL, 1=TRIANGLE CDP SQRT(Z) = DSQRT(Z) CDP ABS(Z) = DABS(Z) KOUNT = 1 DL = TRYDL IF ( LTYPE .EQ. 0 ) DL = DL*2.0 C--> LOCAL COORDINATE CALCULATIONS R(1) = RINOUT S(1) = SINOUT C MARCH ALONG CONTOUR 5 CONTINUE C FORM SHAPE FUNCTION LOCAL DERIVATIVES CALL DERIV (R(KOUNT),S(KOUNT),DH) C FORM LOCAL DERIVATIVE OF VARIABLE, DER = DH*V CALL MMULT (DH,V,DER,2,N,1) GRAD = SQRT( DVDR*DVDR + DVDS*DVDS ) C FIND LOCAL COORD. OF SEGMENT END RNEW = R(KOUNT) - DL*DVDS/GRAD SNEW = S(KOUNT) + DL*DVDR/GRAD C IS NEXT POINT IN THE ELEMENT IF ( LTYPE .EQ. 0 ) THEN C QUADRILATERAL (-1 TO +1): IS POINT OUTSIDE ? 10 IF ( ABS(RNEW) .GT. 1.0 .OR. ABS(SNEW) .GT. 1.0 ) 1 GO TO 20 ELSE C TRIANGLE (UNIT COORDINATES): OUTSIDE ? IF ( RNEW .LT. 0.0 .OR. SNEW .LT. 0.0 .OR. 1 (RNEW+SNEW) .GT. 1.0 ) GO TO 20 ENDIF C ADD POINT TO CONTOUR LIST KOUNT = KOUNT + 1 R(KOUNT) = RNEW S(KOUNT) = SNEW IF ( KOUNT .LT. MAX ) GO TO 5 C--> LINE COMPLETED IN LOCAL COORDINATES 20 CONTINUE IF ( KOUNT .EQ. 1) THEN DL = -DL GO TO 5 ENDIF C RETURN LOCAL COORD. OF LAST POINT RINOUT = R(KOUNT) SINOUT = S(KOUNT) C--> CONVERT TO GLOBAL COORDINATES DO 25 I = 1, KOUNT C EVALUATE SHAPE FUNCTIONS CALL ESHAPE (R(I),S(I),H) C EVALUATE GLOBAL COORDINATES, XYZ = H*COORD CALL MMULT (H,COORD,PXYZ,1,N,NSPACE) XYZ(I,1) = PXYZ(1) XYZ(I,2) = PXYZ(2) IF ( NSPACE .EQ. 3 ) XYZ(I,3) = PXYZ(3) 25 CONTINUE C--> CONTOUR FINISHED, RETURN FOR PLOTTING RETURN END SUBROUTINE LISTI (LOC1, LOC2, NEXTI, IN, IPT, I) C * * * * * * * * * * * * * * * * * * * * * * * * * * * C LIST INTEGER SUB-ARRAYS FROM ARRAY LOC1 TO LOC2 C * * * * * * * * * * * * * * * * * * * * * * * * * * * CHARACTER*8 IN DIMENSION IPT(1), IN(1), I(1) PARAMETER ( IONE=1 ) C C I = Main integer arrays C IN = Names of sub-arrays in I array C IPT = pointer array for sub-arrays in I C LOC = Array location. If < 1 list all. C NEXTI = Next free sub-array in I K1 = 1 K2 = NEXTI - 1 IF ( LOC1 .GE. 1 ) THEN K1 = LOC1 K2 = LOC2 ENDIF WRITE (6,100) 100 FORMAT ( /,' INTEGER SUB-ARRAY DATA:', /) DO 10 K = K1, K2 ISIZE = IPT(K+1) - IPT(K) WRITE (6,200) K, IPT(K), ISIZE, IN(K) 200 FORMAT ( 'NUMBER =',I3,', BEGIN = ',I5,', SIZE = ',I5, 1 ', NAME = ', A8,', CONTENTS:' ) IF ( ISIZE .GT. 0 ) CALL IPRINT (I(IPT(K)),IONE,ISIZE) 10 CONTINUE RETURN END SUBROUTINE LISTR (LOC1, LOC2, NEXTR, RN, JPT, R) C * * * * * * * * * * * * * * * * * * * * * * * * * * * C LIST REAL SUB-ARRAYS FROM LOC1 TO LOC2 C * * * * * * * * * * * * * * * * * * * * * * * * * * * CHARACTER*8 RN DIMENSION JPT(1), RN(1), R(1) PARAMETER ( IONE=1 ) C C R = Main integer arrays C RN = Names of sub-arrays in R array C JPT = pointer array for sub-arrays in R C LOC = Array location. If < 1 list all. C NEXTR = Next free sub-array in R C K1 = 1 K2 = NEXTR - 1 IF ( LOC1 .GE. 1 ) THEN K1 = LOC1 K2 = LOC2 ENDIF WRITE (6,100) 100 FORMAT ( /,' REAL SUB-ARRAY DATA:', /) DO 10 K = K1, K2 ISIZE = JPT(K+1) - JPT(K) WRITE (6,200) K, JPT(K), ISIZE, RN(K) 200 FORMAT ( 'NUMBER =',I3,', BEGIN = ',I5,', SIZE = ',I5, 1 ', NAME = ', A8,', CONTENTS:' ) IF ( ISIZE .GT. 0 ) CALL RPRINT (R(JPT(K)),IONE,ISIZE,IONE) 10 CONTINUE RETURN END SUBROUTINE LNODES (LID, NE, N, NODES, LNODE) C * * * * * * * * * * * * * * * * * * * * * * * * C EXTRACT NODES ASSOCIATED WITH ELEMENT LID C * * * * * * * * * * * * * * * * * * * * * * * * DIMENSION NODES(NE,N), LNODE(N) C NE = NUMBER OF ELEMENTS IN SYSTEM C N = NUMBER OF NODES PER ELEMENT C LID = ELEMENT NUMBER C NODES = NODAL INCIDENCES OF ALL ELEMENTS C LNODE = THE N NODAL INCIDENCES OF THE ELEMENT DO 10 I = 1, N 10 LNODE(I) = NODES(LID,I) RETURN END SUBROUTINE LOBATO (NQP, PT, WT) C * * * * * * * * * * * * * * * * * * * * * * * * * * C LOBATTO QUADRATURE ABSCISSAE AND WEIGHT COEFFS C * * * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8 PT, WT PARAMETER ( NMAX = 10 ) DIMENSION PT(0:NQP), WT(0:NQP) C NQP = NO. OF LOBATTO POINTS IN ONE DIMENSION C PT = ABSCISSAE OF LOBATTO POINTS C WT = WEIGHTS OF LOBATTO POINTS C NMAX = MAX. NO. OF POINTS TABULATED HEREIN NGP = NQP IF ( NGP .GT. NMAX ) THEN NGP = NMAX WRITE (6,*) 'WARNING, LOBATO USED NGP = ', NMAX ENDIF IF ( NGP .LT. 1 ) STOP 'NO POINTS IN LOBATO' IF ( NGP .EQ. 1 ) THEN C... NGP = 1 PT( 1) = 0.00000000000000D+00 WT( 1) = 2.00000000000000D+00 RETURN ELSEIF ( NGP .EQ. 2 ) THEN C... NGP = 2 PT( 1) = 1.00000000000000D+00 WT( 1) = 1.00000000000000D+00 PT( 2) = -PT( 1) WT( 2) = WT( 1) RETURN ELSEIF ( NGP .EQ. 3 ) THEN C... NGP = 3 PT( 1) = 1.00000000000000D+00 WT( 1) = 3.33333333333333D-01 PT( 2) = 0.00000000000000D+00 WT( 2) = 1.33333333333333D+00 PT( 3) = -PT( 1) WT( 3) = WT( 1) RETURN ELSEIF ( NGP .EQ. 4 ) THEN C... NGP = 4 PT( 1) = 1.00000000000000D+00 WT( 1) = 1.66666666666667D-01 PT( 2) = 4.47213595499958D-01 WT( 2) = 8.33333333333333D-01 PT( 3) = -PT( 1) WT( 3) = WT( 1) PT( 4) = -PT( 2) WT( 4) = WT( 2) RETURN ELSEIF ( NGP .EQ. 5 ) THEN C... NGP = 5 PT( 1) = 1.00000000000000D+00 WT( 1) = 1.00000000000000D-01 PT( 2) = 6.54653670707977D-01 WT( 2) = 5.44444444444444D-01 PT( 3) = 0.00000000000000D+00 WT( 3) = 7.11111111111111D-01 PT( 4) = -PT( 1) WT( 4) = WT( 1) PT( 5) = -PT( 2) WT( 5) = WT( 2) RETURN ELSEIF ( NGP .EQ. 6 ) THEN C... NGP = 6 PT( 1) = 1.00000000000000D+00 WT( 1) = 6.66666666666667D-02 PT( 2) = 7.65055323929465D-01 WT( 2) = 3.78474956297847D-01 PT( 3) = 2.85231516480645D-01 WT( 3) = 5.54858377035486D-01 PT( 4) = -PT( 1) WT( 4) = WT( 1) PT( 5) = -PT( 2) WT( 5) = WT( 2) PT( 6) = -PT( 3) WT( 6) = WT( 3) ELSEIF ( NGP .EQ. 7 ) THEN C... NGP = 7 PT( 1) = 1.00000000000000D+00 WT( 1) = 4.7619047619048D-02 PT( 2) = 8.30223896278567D-01 WT( 2) = 2.76826047361566D-01 PT( 3) = 4.68848793470714D-01 WT( 3) = 4.31745381209863D-01 PT( 4) = 0.00000000000000D+00 WT( 4) = 4.87619047619048D-01 PT( 5) = -PT( 1) WT( 5) = WT( 1) PT( 6) = -PT( 2) WT( 6) = WT( 2) PT( 7) = -PT( 3) WT( 7) = WT( 3) RETURN ELSEIF ( NGP .EQ. 8 ) THEN C... NGP = 8 PT( 1) = 1.00000000000000D+00 WT( 1) = 3.5714285714286D-02 PT( 2) = 8.71740148509607D-01 WT( 2) = 2.10704227143506D-01 PT( 3) = 5.91700181433142D-01 WT( 3) = 3.41122692483504D-01 PT( 4) = 2.09299217902479D-01 WT( 4) = 4.12458794658704D-01 PT( 5) = -PT( 1) WT( 5) = WT( 1) PT( 6) = -PT( 2) WT( 6) = WT( 2) PT( 7) = -PT( 3) WT( 7) = WT( 3) PT( 8) = -PT( 4) WT( 8) = WT( 4) RETURN ELSEIF ( NGP .EQ. 9 ) THEN C... NGP = 9 PT( 1) = 1.00000000000000D+00 WT( 1) = 2.77777777777778D-02 PT( 2) = 8.99757995411460D-01 WT( 2) = 1.65495361560805D-01 PT( 3) = 6.77186279510738D-01 WT( 3) = 2.74538712500162D-01 PT( 4) = 3.63117463826178D-01 WT( 4) = 3.46428510973406D-01 PT( 5) = 0.00000000000000D+00 WT( 5) = 3.71519274376417D-01 PT( 6) = -PT( 1) WT( 6) = WT( 1) PT( 7) = -PT( 2) WT( 7) = WT( 2) PT( 8) = -PT( 3) WT( 8) = WT( 3) PT( 9) = -PT( 4) WT( 9) = WT( 4) RETURN ELSEIF ( NGP .EQ. 10 ) THEN C... NGP = 10 PT( 1) = 1.00000000000000D+00 WT( 1) = 2.22222222222222D-02 PT( 2) = 9.19533908166459D-01 WT( 2) = 1.33305990851070D-01 PT( 3) = 7.38773865105505D-01 WT( 3) = 2.24889342063126D-01 PT( 4) = 4.77924949810444D-01 WT( 4) = 2.92042683679684D-01 PT( 5) = 1.65278957666387D-01 WT( 5) = 3.27539761183897D-01 PT( 6) = -PT( 1) WT( 6) = WT( 1) PT( 7) = -PT( 2) WT( 7) = WT( 2) PT( 8) = -PT( 3) WT( 8) = WT( 3) PT( 9) = -PT( 4) WT( 9) = WT( 4) PT(10) = -PT( 5) WT(10) = WT( 5) RETURN ENDIF RETURN END SUBROUTINE LPTPRT (N, M, NNPFLO, FLTNP, PRTLPT, 1 NNPFIX, NPFIX, LPPROP, LNODE, NHOMO) C * * * * * * * * * * * * * * * * * * * * * * * * * * C EXTRACT FLOATING POINT PROPERTIES AT NODAL POINTS C OF AN ELEMENT C * * * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8 (A-H,O-Z) DIMENSION FLTNP(M,0:NNPFLO), PRTLPT(N,0:NNPFLO), 1 NPFIX(M,0:NNPFIX), LPPROP(N,0:NNPFIX), 2 LNODE(N) C FLTNP = FLOATING POINT PROP ARRAY OF SYSTEM NODES C PRTLPT = FLOATING POINT PROP ARRAY OF ELEMENT NODES C NPFIX = INTEGER PROPERTY ARRAY OF SYSTEM NODES C LPPROP = INTEGER PROPERTY ARRAY OF ELEMENT NODES C LNODE = ELEMENT INCIDENCES ARRAY OF THE ELEMENT C M = NUMBER OF SYSTEM NODES C N = NUMBER OF NODES PER ELEMENT C NNPFIX = NUMBER OF INTEGER PROPERTIES PER NODE C NNPFLO = NUMBER OF REAL PROPERTIES PER NODE C NHOMO = 1, IF PROPERTIES ARE SAME AT EACH NODE DO 20 I = 1, N IROW = LNODE(I) C ALLOW FOR OMITTED NODES IF ( IROW .GT. 0 ) THEN IF ( NHOMO .EQ. 1 ) IROW = 1 IF ( NNPFLO .GT. 0 ) THEN DO 10 J = 1, NNPFLO 10 PRTLPT(I,J) = FLTNP(IROW,J) ENDIF IF ( NNPFIX .GT. 0 ) THEN DO 30 J = 1, NNPFIX 30 LPPROP(I,J) = NPFIX(IROW,J) ENDIF ENDIF 20 CONTINUE RETURN END SUBROUTINE MADD (A, B, C, M, N) C * * * * * * * * * * * * * * * * * * * * * * * * * * C MATRIX ADDITION A(M,N)+B(M,N)=C(M,N) C * * * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8 (A-H,O-Z) DIMENSION A(M*N), B(M*N), C(M*N) MN = M*N DO 10 I = 1,MN 10 C(I) = A(I) + B(I) RETURN END SUBROUTINE MATPRT (NUM,NLPFLO,MISCFL,FLTMIS,PRTMAT) C * * * * * * * * * * * * * * * * * * * * * * * * * * C EXTRACT REAL MATERIAL PROPERTIES OF MATERIAL C NUM FROM MISCELLANEOUS REAL SYSTEM PROPERTIES C * * * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8 (A-H,O-Z) DIMENSION FLTMIS(0:MISCFL), PRTMAT(0:NLPFLO) C NUM = MATERIAL NUMBER C NMAX = MAXIMUM ALLOWABLE MATERIAL NUMBER C NLPFLO = NUMBER OF REAL ELEMENT PROPERTIES C MISCFL = NO OF MISC REAL SYSTEM PROPERTIES C FLTMIS = SYSTEM STORAGE FOR MISC REAL PROP C PRTMAT = REAL PROPERTY ARRAY FOR MATERIAL NUM C PROPERTIES ARE STORED IN FLTMIS IN ORDER OF MAT NO IF ( NLPFLO .LT. 1 ) STOP 'BAD NLPFLO, MATPRT' NMAX = MISCFL/NLPFLO IF ( NUM .GT. NMAX ) STOP 'DIMENSIONS EXCEEDED, MATPRT' ISTART = NLPFLO*(NUM - 1) DO 10 I = 1, NLPFLO 10 PRTMAT(I) = FLTMIS(ISTART+I) RETURN END SUBROUTINE MATWRT (NLPFLO,MISCFL,FLTMIS,PRTMAT) C * * * * * * * * * * * * * * * * * * * * * * * * * C LIST REAL PROPERTIES BY MATERIAL NUMBER C * * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8 (A-H,O-Z) PARAMETER ( NPRT = 6 ) DIMENSION FLTMIS(0:MISCFL), PRTMAT(0:NLPFLO) C NLPFLO = NUMBER OF REAL ELEMENT PROP C MISCFL = NUMBER OF MISC REAL SYSTEM PROP C FLTMIS = SYSTEM STORAGE OF MISC REAL PROP C PRTMAT = REAL PROP ARRAY FOR MATERIAL NUM C NMAX = MAXIMUM ALLOWABLE MATERIAL NUMBER IF ( NLPFLO .LT. 1 .OR. NLPFLO .GT. MISCFL ) THEN WRITE (NPRT,*) NLPFLO, MISCFL STOP 'BAD NLPFLO, MATWRT' ENDIF NMAX = MISCFL/NLPFLO WRITE (NPRT,5000) NLPFLO 5000 FORMAT ( /, '** LIST OF REAL MATERIAL PROPERTIES **',/, 2'MATERIAL,',I4,' REAL PROPERTIES') DO 10 I = 1, NMAX CALL MATPRT (I,NLPFLO,MISCFL,FLTMIS,PRTMAT) WRITE (NPRT,5010) I, (PRTMAT(J), J=1,NLPFLO) 5010 FORMAT ( I5, (10(1PE12.4)) ) 10 CONTINUE RETURN END SUBROUTINE MAXMIN (M, NG, NDFREE, IPRINT, RANGE, DD, 1 INDEX, NRANGE) C * * * * * * * * * * * * * * * * * * * * * * * * * * C FIND EXTREME RANGE OF VALUES OF THE NG NODAL DOF C * * * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8(A-H,O-Z) PARAMETER ( NPRT = 6 ) DIMENSION DD(NDFREE), RANGE(NG,2), INDEX(NG), 1 NRANGE(NG,2) C M = NUMBER OF NODES IN SYSTEM C NG = NUMBER OF PARAMETERS (DOF) PER NODE C NDFREE = TOTAL NUMBER OF SYSTEM DEGREES OF FREEDOM C IPRINT > 0 PRINT RANGE OF VALUES C RANGE : 1-MAXIMUM VALUE, 2-MINIMUM VALUE C DD = ARRAY OF SYSTEM DEGREES OF FREEDOM C INDEX = LIST OF SYSTEM DOF NOS FOR DOF AT NODE C NRANGE = ARRAY OF NODE NOS OF EXTREME VALUE POINTS DO 10 J = 1, NG NRANGE(J,1) = 0 NRANGE(J,2) = 0 RANGE(J,1) = DD(J) 10 RANGE(J,2) = DD(J) DO 40 I = 1, M CALL INDXPT (I,NG,INDEX) DO 30 J = 1,NG DDTEST = DD(INDEX(J)) IF ( DDTEST .LT. RANGE(J,1) ) GO TO 20 RANGE(J,1) = DDTEST NRANGE(J,1) = I 20 IF ( DDTEST.GT.RANGE(J,2) ) GO TO 30 RANGE(J,2) = DDTEST NRANGE(J,2) = I 30 CONTINUE 40 CONTINUE IF ( IPRINT .EQ. 0 ) RETURN C PRINT RANGE OF VALUES WRITE (NPRT,5000) 5000 FORMAT ( /, 1 '*** EXTREME VALUES OF THE NODAL PARAMETERS ***',/, 2 'PARAMETER MAXIMUM, NODE MINIMUM, NODE') DO 50 J = 1, NG 50 WRITE (NPRT,5010) J, RANGE(J,1), NRANGE(J,1), 1 RANGE(J,2), NRANGE(J,2) 5010 FORMAT (I7,2X,1PE11.4,',',I5,2X,1PE11.4,',',I5) RETURN END SUBROUTINE MMDIFF (A, B, C, D, L, M, N) C * * * * * * * * * * * * * * * * * * * * * * * * * * C PRODUCT OF MATRIX TIMES DIFFERENCE IN MATRICES C D(L,N) = A(L,M) * ( B(M,N) - C(M,N) ) C * * * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8 (A-H,O-Z) PARAMETER ( ZERO = 0.0 ) DIMENSION A(L,M), B(M,N), C(M,N), D(L,N) DO 30 I = 1, L DO 20 J = 1, N SUM = ZERO DO 10 K = 1, M BKJ = B(K,J) - C(K,J) IF ( BKJ .EQ. ZERO ) GO TO 10 AIK = A(I,K) IF ( AIK .EQ. ZERO ) GO TO 10 SUM = SUM + AIK*BKJ 10 CONTINUE D(I,J) = SUM 20 CONTINUE 30 CONTINUE RETURN END SUBROUTINE MMULT (A, B, C, L, M, N) C * * * * * * * * * * * * * * * * * * * * * * * * * * C MATRIX MULTIPLICATION: A(L,M) * B(M,N) = C(L,N) C * * * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8 (A-H,O-Z) PARAMETER ( ZERO = 0.0 ) DIMENSION A(L,M), B(M,N), C(L,N) DO 30 I = 1, L DO 20 J = 1, N SUM = ZERO DO 10 K = 1, M BKJ = B(K,J) IF ( BKJ .EQ. ZERO ) GO TO 10 AIK = A(I,K) IF ( AIK .EQ. ZERO ) GO TO 10 SUM = SUM + AIK*BKJ 10 CONTINUE C(I,J) = SUM 20 CONTINUE 30 CONTINUE RETURN END SUBROUTINE MMULTT (A,B,C,L,M,N) C * * * * * * * * * * * * * * * * * * * * * * * * * * C MATRIX PRODUCT TRANSPOSED C C(N,L) = ( A(L,M)*B(M,N) )T C * * * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8 (A-H,O-Z) DIMENSION A(L,M), B(M,N), C(N,L) ZERO = 0.0 DO 30 I = 1,L DO 20 J = 1,N SUM = ZERO DO 10 K = 1,M BKJ = B(K,J) IF ( BKJ.EQ.ZERO ) GO TO 10 AIK = A(I,K) IF ( AIK.EQ.ZERO ) GO TO 10 SUM = SUM + AIK*BKJ 10 CONTINUE C(J,I) = SUM 20 CONTINUE 30 CONTINUE RETURN END SUBROUTINE MODEL96 (MAXR, MAXI, NUMR, NUMI, LASTR, LASTI, 1 NEXTR, NEXTI, RARRAY, RNAME, IARRAY, INAME, JRARAY, JIARAY, A TITLE, NSEG, LBN, NITER, NCURVE, INRHS, ISAY, NNPFIX, B NLPFIX, MISCFX, MISCFL, NHOMO, LHOMO, NPTWRT, LEMWRT, C NTAPE1, NTAPE2, NTAPE3, NTAPE4, NTAPE5, NULCOL, MAXTYP, D NLTYPE, NUMCE, IPTEST, LPTEST, MODE, M, MAXACT , E N, NC, NCOEFF, NDFREE, NE, NELFRE, NGF, NFLUX, F NG, NGEOM, NLPFLO, NNPFLO, NOMAT, NPARM, NPLT, NQP, NRB, G NSPACE, NSYS, NTMP , LSHAPE, IBUG, NBSFIX, H NBSFLO, X, AJ, AJINV, AVE, B, BODY, C, CC, CEQ, COORD, D, 4 DDOLD, DGH, DLG, DLH, E, EB, ELPROP, FLTEL, FLTBS, 5 FLTMIS, FLTNP, FLUX, FLUXBS, G, GPT, GWT, H, HINTG, 6 PLTSET, PRTLPT, PRTMAT, PT, RANGE, S, SATPT, STRAIN, 7 STRAN0, STRESS, SYSDAT, TMP, VALC, VALE, WT, XPT, XYZ, 8 DD, USEREL, USERPT, SS, IBC, KODES, NODES, NRES, LTYPE, IADD, 9 IDIAG, INDEX, LFIRST, LLAST, LNODE, LPFIX, NBSPFX, LPPROP, 2 LPROP, LTDATA, MISFIX, NDXC, NODEF, NRANGE, NREQ, NPFIX, LHIGH ) c 1 2 3 4 5 6 712 c23456789012345678901234567890123456789012345678901234567890-----------X C C ****************************************************** C * -M-O-D-E-L- * C * MODULAR PROGRAMS FOR FINITE ELEMENT ANALYSES * C * COPYRIGHT J. E. AKIN, 1996 * C ****************************************************** C C A SET OF BUILDING BLOCK PROGRAMS C BY C DR. J. E. AKIN, P.E. C DEPT. OF MECHANICAL ENGINEERING & MATERIALS SCIENCE C RICE UNIVERSITY C HOUSTON, TEXAS 77251-1892 C C email: akin@rice.edu C C WARNING: USE COMPILE FLAG FOR EXTRA CONTINUATIONS: -Nl40 C PARAMETER ( NREACT = 20, CUTOFF = 1.E-6 ) LOGICAL FACT, BACK cb DIMENSION TITLE(15), RARRAY(MAXR), RNAME(NUMR), cb 4 DDOLD(NDFREE), DGH(NSPACE,N,0:NQP), DLG(NPARM,NGEOM,0:NQP), cb 5 DLH(NSPACE,N,0:NQP), E(NRB,NRB), EB(NRB,NELFRE), CHARACTER*8 RNAME(NUMR), INAME(NUMI) CHARACTER*4 TITLE(15) DIMENSION RARRAY(MAXR), 1 X(M,NSPACE), AJ(NSPACE,NSPACE), AJINV(NSPACE,NSPACE), 2 AVE(0:M,NRB+2), B(NRB,NELFRE), BODY(NSPACE), C(NELFRE), 3 CC(NDFREE), CEQ(MAXACT,NUMCE), COORD(N,NSPACE), D(NELFRE), 4 DDOLD(NDFREE), DGH(NSPACE,nelfre,0:NQP), DLG(NPARM,NGEOM,0:NQP), 5 DLH(NSPACE,nelfre,0:NQP), E(NRB,NRB), EB(NRB,NELFRE), 6 ELPROP(0:NLPFLO), FLTEL(NE,0:NLPFLO), FLTBS(0:NSEG,0:NBSFLO), 7 FLTMIS(0:MISCFL), FLTNP(M,0:NNPFLO), FLUX(0:NGF), 8 FLUXBS(0:NSEG,0:NFLUX), G(NGEOM,0:NQP), GPT(0:NQP), GWT(0:NQP) cb DIMENSION H(N,0:NQP), HINTG(N,0:NQP+1), PLTSET(0:NPLT), DIMENSION H(nelfre,0:NQP), HINTG(nelfre,0:NQP+1), PLTSET(0:NPLT), 1 PRTLPT(N,0:NNPFLO), PRTMAT(0:NLPFLO,0:NOMAT), PT(NPARM,0:NQP), 2 RANGE(NG,2), S(NELFRE,NELFRE), SATPT(NRB+2,N), 3 STRAIN(NRB+2),STRAN0(NRB), STRESS(NRB+2), SYSDAT(0:NSYS), 4 TMP(0:NTMP), VALC(NRB,0:NC), VALE(NRB,0:NC), WT(0:NQP), 5 XPT(NSPACE,2), XYZ(NSPACE), DD(NDFREE), USEREL(NG,N), 6 USERPT(NG), SS(1) cb DIMENSION IARRAY(MAXI), INAME(NUMI), IBC(M), KODES(NG), DIMENSION IARRAY(MAXI), IBC(M), KODES(NG), 1 NODES(NE,N), NRES(MAXTYP), LTYPE(NE), IADD(0:M), 2 IDIAG(NDFREE), INDEX(NELFRE), LFIRST(M), LLAST(M), LNODE(N), 3 LPFIX(NE,0:NLPFIX), NBSPFX(0:NSEG,0:NBSFIX), LPPROP(0:NNPFIX), 4 LPROP(0:NLPFIX), LTDATA(6,NLTYPE), MISFIX(0:MISCFX), 5 NDXC(MAXACT,NUMCE), NODEF(0:NSEG,0:LBN), NRANGE(NG,2), 6 NREQ(MAXTYP), NPFIX(M,0:NNPFIX), LHIGH(NELFRE), 7 JRARAY(NUMR), JIARAY(NUMI) c 1 2 3 4 5 6 712 c23456789012345678901234567890123456789012345678901234567890-----------X C ...................... NOTATION ...................... C SEE TEXT OR notation.f C ...................................................... cb IF ( IT .GT. 1 .AND. NREACT .GT. 0 ) REWIND (NREACT) IF ( NREACT .GT. 0 ) OPEN (NREACT, FILE = 'REACTS.BIN', & STATUS = 'UNKNOWN', FORM='UNFORMATTED') IF ( NTAPE1 .GT. 0 ) OPEN (NTAPE1, FILE = 'NTAPE1.BIN', & STATUS = 'UNKNOWN', FORM='UNFORMATTED') IF ( NTAPE2 .GT. 0 ) OPEN (NTAPE2, FILE = 'NTAPE2.BIN', & STATUS = 'UNKNOWN', FORM='UNFORMATTED') IF ( NTAPE3 .GT. 0 ) OPEN (NTAPE3, FILE = 'NTAPE3.BIN', & STATUS = 'UNKNOWN', FORM='UNFORMATTED') IF ( NTAPE4 .GT. 0 ) OPEN (NTAPE4, FILE = 'NTAPE4.BIN', & STATUS = 'UNKNOWN', FORM='UNFORMATTED') IF ( NTAPE5 .GT. 0 ) OPEN (NTAPE5, FILE = 'NTAPE5.BIN', & STATUS = 'UNKNOWN', FORM='UNFORMATTED') IF ( IBUG .EQ. 1 ) THEN WRITE (6,5030) M, NE, NG, N, NSPACE, NSEG, LBN, NGF, 1 NITER, NCURVE, INRHS, ISAY, NRB, NQP, 2 LSHAPE, NLTYPE, MODE 5030 FORMAT ( /, '***** PROBLEM PARAMETERS *****',/, 1 'NUMBER OF NODAL POINTS IN SYSTEM ........',I5,/, 2 'NUMBER OF ELEMENTS IN SYSTEM ............',I5,/, 4 'NUMBER OF PARAMETERS PER NODE ...........',I5,/, 3 'NUMBER OF NODES PER ELEMENT .............',I5,/, 5 'DIMENSION OF SPACE ......................',I5,/, 6 'NUMBER OF BOUNDARIES WITH GIVEN FLUX ....',I5,/, 7 'NUMBER OF NODES ON BOUNDARY SEGMENT .....',I5,/, 8 'NUMBER OF FLUX COMPONENTS PER NODE.......',I5,/, 8 'NUMBER OF ITERATIONS TO BE RUN ..........',I5,/, 9 'NUMBER OF CONTOURS BETWEEN 5 & 95% ......',I5,/, + 'INITIAL FORCING VECTOR INPUT FLAG .......',I5,/, 1 'NUMBER OF USER REMARKS LINES ............',I5,/, 2 'NUMBER OF ROWS IN B MATRIX ..............',I5,/, 3 'NUMBER OF QUADRATURE POINTS .............',I5,/, 4 'SHAPE 1-LINE 2-TRI 3-QUAD 4-HEX 5-TET ...',I5,/, 5 'NUMBER OF DIFFERENT ELEMENT TYPES .......',I5,/, 6 'STIFFNESS STORAGE MODE: SKY, BAND .......',I5) IF ( LBN .GT. N ) WRITE (6,*) 1 'INCONSISTANT VALUES OF LBN AND N.' WRITE (6,5080) NNPFIX, NNPFLO, NLPFIX, NLPFLO, 1 NBSFIX, NBSFLO, MISCFX, MISCFL 5080 FORMAT ( 1 'NUMBER OF INTEGER PROPERTIES PER NODE .......',I5,/, 2 'NUMBER OF REAL PROPERTIES PER NODE ..........',I5,/, 3 'NUMBER OF INTEGER PROPERTIES PER ELEMENT ....',I5,/, 4 'NUMBER OF REAL PROPERTIES PER ELEMENT .......',I5,/, 3 'NUMBER OF INTEGER PROPERTIES PER SEGMENT ....',I5,/, 4 'NUMBER OF REAL PROPERTIES PER SEGMENT .......',I5,/, 5 'NUMBER OF INTEGER MISCELLANEOUS PROPERTIES .',I5,/, 6 'NUMBER OF REAL MISCELLANEOUS PROPERTIES ....',I5) WRITE (6,5081) NELFRE, NFLUX, NDFREE 5081 FORMAT ( 1 'NUMBER OF D.O.F. FOR ELEMENT .......',I5,/, 2 'NUMBER OF D.O.F. ON FLUX SEGMENT ...',I5,/, 3 'NUMBER OF D.O.F. IN TOTAL SYSTEM ...',I5) IF ( NHOMO .EQ. 1 ) WRITE (6,*) 1 'NODAL POINT PROPERTIES ARE HOMOGENEOUS.' IF ( LHOMO .EQ. 1 ) WRITE (6,*) 1 'ELEMENT PROPERTIES ARE HOMOGENEOUS.' NSUM = NTAPE1 + NTAPE2 + NTAPE3 + NTAPE4 + NTAPE5 IF ( NSUM .GT. 0 ) 1 WRITE (6,5180) NTAPE1, NTAPE2, NTAPE3, NTAPE4, NTAPE5 5180 FORMAT ( /, 'OPTIONAL UNIT NUMBERS (UTILIZED IF > 0)',/, 1 'NTAPE1 = ',I2,', NTAPE2 = ',I2,/,'NTAPE3 = ',I2, 2 ', NTAPE4 = ',I2,', NTAPE5 = ',I2) IF ( NPTWRT .EQ. 0 ) WRITE (6,*) 1 'NODAL PARAMETERS TO BE LISTED BY NODES' IF ( LEMWRT .EQ. 0 ) WRITE (6,*) 1 'NODAL PARAMETERS TO BE LISTED BY ELEMENTS' IF ( NULCOL .NE. 0 ) WRITE (6,*) 1 'ALL ELEMENT COLUMN MATRICES ARE ZERO.' ENDIF C ZERO SYSTEM SOURCE VECTOR CALL ZEROA (NDFREE, CC) C C--> SET OR READ ELEMENT TYPE DATA CALL INLTYP (NLTYPE, LTDATA, N, NQP, NGEOM, NPARM, LSHAPE) C C--> *** READ NODAL PARAMETER CONSTRAINT EQUATIONS *** C IBUG2 = IBUG ibug = 0 c IF ( IBUG .GT. 0 ) THEN C LOC = 0 C CALL SIZEI (LOC, NEXTI, INAME, JIARAY) C CALL SIZER (LOC, NEXTR, RNAME, JRARAY) LOC1 = 0 LOC2 = 0 CALL LISTI (LOC1, LOC2, NEXTI, INAME, JIARAY, IARRAY) CALL LISTR (LOC1, LOC2, NEXTR, RNAME, JRARAY, RARRAY) ENDIF CALL INCEQ (NG, MAXACT, NUMCE, NREQ, CEQ, NDXC, M) IF ( MODE .EQ. 1 ) THEN C C DETERMINE SYSTEM HALF-BANDWIDTH C CALL SYSBAN (NE, N, NG, IBW, NODES, LNODE, LID) JBW = 1 IF ( MAXACT.GT.1 ) 1 CALL CEQBAN (JBW, NREQ, MAXACT, NUMCE, NDXC, NDFREE) MAXBAN = MAX0 ( JBW,IBW ) WRITE (6,5110) IBW, LID, JBW, MAXBAN 5110 FORMAT ( /, 1 'EQUATION HALF BANDWIDTH ............',I5,/, 2 'OCCURS IN ELEMENT NUMBER . .........',I5,/, 3 'CONSTRAINT HALF BANDWIDTH ..........',I5,/, 4 'MAXIMUM HALF BANDWIDTH OF SYSTEM ...',I5) NCOEFF = NDFREE*MAXBAN ELSE C C SKYLINE C CALL SYSSKY (NDFREE, NE, N, NG, NELFRE, NODES, C 1 LNODE, INDEX, LHIGH, IDIAG ) C IF ( MAXACT.GT.1 ) C 1 CALL CEQSKY (IDIAG, NREQ, MAXACT, NUMCE, NDXC, NDFREE) C NCOEFF = IDIAG(NDFREE) ENDIF WRITE (6,5111) NDFREE, NCOEFF 5111 FORMAT ( 1 'TOTAL NUMBER OF SYSTEM EQUATIONS ...',I5,/, 2 'NUMBER OF STIFFNESS COEFFICIENTS ...',I5) LASTR = LASTR + NCOEFF 10 WRITE (6,5120) LASTR, MAXR, LASTI, MAXI 5120 FORMAT ( /, '*** ARRAY STORAGE ***',/, 1 'TYPE REQUIRED AVAILABLE',/, 2 'REAL ', 2X, I5, 2X, I5,/, 3 'INTEGER', 2X, I5, 2X, I5) C C UPDATE POINTER AFTER SS NOW THAT SIZE IS KNOWN C JRARAY(NEXTR) = JRARAY(NEXTR - 1) + NCOEFF C C COMPLETE POINTERS C C CHECK DATA AGAINST DIMENSION STATEMENTS IF ( LASTR .GT. MAXR .OR. LASTI .GT. MAXI ) THEN WRITE (6,*) 'ERROR: IN DRIVER SET MAXR > ', LASTR WRITE (6,*) 'ERROR: IN DRIVER SET MAXI > ', LASTI STOP 'STORAGE EXCEEDED IN DRIVER, ABNORMAL PROGRAM END' ENDIF C C ZERO THE SYSTEM SQUARE MATRIX C CALL ZEROA (NCOEFF, SS) C C--> *** READ PROPERTIES *** IF ( IPTEST .GT. 0 ) THEN CALL INPROP (M, NE, NNPFIX, NNPFLO, NLPFIX, NLPFLO, 1 MISCFX, MISCFL, FLTNP, FLTEL, FLTMIS, 2 NPFIX, LPFIX, MISFIX, NHOMO, LHOMO, 3 NBSFIX, NBSFLO, NBSPFX, FLTBS, NSEG) ELSE WRITE (6,*) 'WARNING, NO PROPERTY INPUT' ENDIF IF ( IBUG .GT. 0 ) THEN LOC1 = 0 LOC2 = 0 CALL LISTI (LOC1, LOC2, NEXTI, INAME, JIARAY, IARRAY) CALL LISTR (LOC1, LOC2, NEXTR, RNAME, JRARAY, RARRAY) ENDIF C C--> ** INPUT INITIAL FORCING VECTOR ** C cb call at(237) IF ( INRHS .GT. 0 ) CALL INVECT (NDFREE, NG, CC, M, D) C C--> ** READ FLUX BOUNDARY SOURCES & ADD TO SYSTEM EQS ** C cb call at(242) IF ( NSEG .GT. 0 ) 1 CALL INFLUX (NSEG, LBN, LNODE, FLUX, NG, COORD, 2 NSPACE, X, M, INDEX, C, CC, NDFREE, 3 S, SS, NCOEFF, NFLUX, MODE, N, IOPT, 4 NQP, NPARM, H, DGH, PT, WT, XYZ, DLH, 5 G, DLG, AJ, AJINV, LHOMO, NBSFIX, 6 NBSFLO, NBSPFX, FLTBS, GPT, GWT, NGF ) C C INITIALIZE SYSTEM DOF FOR ITERATIVE SOLUTION C IF ( NITER .GT. 1 ) 1 CALL DSTART (1, M, NG, NSPACE, NDFREE, INDEX, X, 2 COORD, DDOLD) IF ( IBUG .GT. 0 ) THEN LOC1 = 0 LOC2 = 0 CALL LISTI (LOC1, LOC2, NEXTI, INAME, JIARAY, IARRAY) CALL LISTR (LOC1, LOC2, NEXTR, RNAME, JRARAY, RARRAY) ENDIF C C *** BEGIN ITERATION LOOP *** C RATIO = 1.0 DO 30 IT = 1, NITER cb call at(267) C C--> *** CALCULATE AND ASSEMBLE ELEMENT MATRICES *** C--> *** GENERATE POST SOLUTION MATRICES & STORE *** C cb call at(272) CALL ASYMBL ( NG, NCOEFF, MODE, IDIAG, NODES, SS, 1 CC, M, NE, NDFREE, NITER, LPTEST, LHOMO, 2 NHOMO, NULCOL, N, NSPACE, NELFRE, NRB, NQP, NGEOM, 3 NPARM, NNPFIX, NNPFLO, MISCFX, MISCFL, NLPFIX, NLPFLO, 4 LNODE, INDEX, X, DDOLD, COORD, S, C, H, DGH, B, E, EB, 5 STRAIN, STRAN0, STRESS, BODY, PT, WT, XYZ, DLH, G, DLG, 6 AJ, AJINV, HINTG, D, PRTLPT, FLTNP, FLTEL, FLTMIS, 7 ELPROP, PRTMAT, MISFIX, NPFIX, LPFIX, LPROP, LPPROP, 8 NTAPE1, NTAPE2, NTAPE3, NTAPE4, NTAPE5, 9 LTYPE, NLTYPE, LTDATA, LSHAPE, GPT, GWT ) c call rprint(cc,ndfree,1,1) C C *** ASSEMBLY COMPLETED, CHECK SOURCES *** C IF ( IBUG2 .GT. 0 ) THEN LOC1 = 0 LOC2 = 0 CALL LISTI (LOC1, LOC2, NEXTI, INAME, JIARAY, IARRAY) CALL LISTR (LOC1, LOC2, NEXTR, RNAME, JRARAY, RARRAY) ENDIF c print *, 'lnode, index' c call iprint(lnode,1,n) c call iprint(index,1,nelfre) CALL SUMIN (NDFREE, M, NG, CC, D) c print *, 'lnode, index' c call iprint(lnode,1,n) c call iprint(index,1,nelfre) C C ** SAVE DATA FOR REACTION RECOVERY ** C IBCSUM = 0 DO 123 IM = 1, M IBCSUM = IBCSUM + IBC(IM) 123 CONTINUE IF ( IBCSUM .GT. 0 ) THEN C REACTIONS EXIST IF ( MODE .EQ. 1 ) THEN C BANDED MODE c print *, 'lnode, index' c call iprint(lnode,1,n) c call iprint(index,1,nelfre) CALL SAVBAN (NREACT, M, NDFREE, NG, MAXBAN, IBC, 1 INDEX, KODES, SS, CC) c print *, 'lnode, index' c call iprint(lnode,1,n) c call iprint(index,1,nelfre) ELSE C SKYLINE MODE C CALL SAVSKY (NREACT, M, NDFREE, NG, NCOEFF, IBC, C 1 INDEX, KODES, SS, CC, IDIAG) ENDIF ENDIF c print *, 'lnode, index' c call iprint(lnode,1,n) c call iprint(index,1,nelfre) C C--> ** APPLY BOUNDARY CONSTRAINTS TO NODAL PARAMETERS ** C CALL APLYBC (MAXACT, NUMCE, NREQ, CEQ, NDXC, 1 NDFREE, NCOEFF, SS, CC, IBW, IDIAG, MODE ) c print *, 'lnode, index' c call iprint(lnode,1,n) c call iprint(index,1,nelfre) c call rprint(cc,ndfree,1,1) C C ** CHECK OR FIX SQUARE MATRIX ** C IF ( MODE .EQ. 1 ) THEN C BANDED MODE CALL BANCHK (NDFREE, MAXBAN, M, NG, SS, CC) ELSE C SKYLINE MODE C CALL SKYCHK (NDFREE, NCOEFF, M, NG, SS, CC, IDIAG) ENDIF C C--> *** SOLVE FOR UNKNOWN NODAL PARAMETERS *** C IF ( MODE .EQ. 1 ) THEN C BANDED MODE MAXBAN = NCOEFF/NDFREE CALL FACTOR (NDFREE, MAXBAN, SS) CALL SOLVE (NDFREE, MAXBAN, SS, CC, DD) ELSE C SKYLINE MODE FACT = .TRUE. BACK = .TRUE. C CALL SKYSOLVE (SS, CC, DD, IDIAG, NDFREE, FACT, BACK, C 1 NCOEFF) ENDIF C C--> *** SOLUTION COMPLETE, GET SYSTEM REACTIONS *** C IF ( IBUG2 .GT. 0 ) THEN LOC1 = 0 LOC2 = 0 CALL LISTI (LOC1, LOC2, NEXTI, INAME, JIARAY, IARRAY) CALL LISTR (LOC1, LOC2, NEXTR, RNAME, JRARAY, RARRAY) ENDIF cb call at(371) c call rprint(cc,ndfree,1,1) IF ( NREACT .GT. 0 .AND. IBCSUM .GT. 0 ) 1 CALL REACTS (NREACT, NDFREE, NG, MODE, DD, D) c call at(375) C C *** PRINT RESULTS *** C CALL MAXMIN (M, NG, NDFREE, 1, RANGE, DD, INDEX, NRANGE) IF ( NPTWRT .EQ. 0 ) 1 CALL WRTPT (M, NG, NDFREE, NSPACE, X, DD, INDEX) IF ( LEMWRT .EQ. 0 ) 1 CALL WRTELM (NE, N, NG, NDFREE, NELFRE, DD, INDEX, 2 NODES, LNODE) C C--> *** POST SOLUTION CALCULATIONS *** C c print *, 'lnode, index' c call iprint(lnode,1,n) c call iprint(index,1,nelfre) IF ( NTAPE1 .GT. 0 ) 1 CALL POST ( M, NE, NG, NDFREE, NODES, LNODE, INDEX, 1 DD, N, NSPACE, NELFRE, NRB, NQP, NGEOM, NPARM, NNPFIX, 2 NNPFLO, MISCFX, MISCFL, NLPFIX, NLPFLO, COORD, S, C, H, 3 DGH, B, E, EB, STRAIN, STRAN0, STRESS, BODY, PT, WT, 4 XYZ, DLH, G, DLG, AJ, AJINV, HINTG, D, PRTLPT, FLTMIS, 5 ELPROP, PRTMAT, MISFIX, LSHAPE, LPROP, LPPROP, 6 NTAPE1, NTAPE2, NTAPE3, NTAPE4, NTAPE5, IT, NITER, 7 LTYPE, NLTYPE, LTDATA, GPT, GWT, LHOMO, FLTNP, FLTEL, 8 NPFIX, LPFIX, USEREL, USERPT, AVE, IADD ) IF ( NITER .GT. 1 ) THEN IF ( IT .EQ. 1 ) RTEST = RATIO C C *** UPDATE VALUES FOR NEXT ITERATION (IF ANY) *** C WRITE (6,*) ' ' WRITE (6,*) 'ITERATION NUMBER = ', IT CALL CHANGE (NDFREE, DD, DDOLD, TOTAL, DIFF, RATIO, 1) IF ( (RATIO/RTEST) .LT. CUTOFF ) GO TO 35 CALL CORECT (NDFREE, DD, DDOLD) CALL ZEROA (NCOEFF, SS) CALL ZEROA (NDFREE, CC) ENDIF 30 CONTINUE 35 IF ( NCURVE .GT. 0 ) THEN C C ** CALCULATE CONTOUR CURVES FOR NODAL PARAMETERS ** C C CALL CONTUR (M, NE, N, NG, NSPACE, NDFREE, NELFRE, NCURVE, C 1 X, COORD, XYZ, DD, D, RANGE, NODES, LNODE, INDEX) ENDIF C C ** BAR CHART OF SOULTION ** C IBAR = 1 NODIST = 0 NDUMMY = 0 DO 40 IPARM = 1, NG CALL BARPRT (M, NDFREE, NG, NSPACE, IBAR, IPARM, NODIST, X, 1 DD, NDUMMY) 40 CONTINUE C C *** PROBLEM COMPLETED *** C WRITE (6,*) 'NORMAL ENDING OF MODEL PROGRAM.' RETURN END SUBROUTINE MODFUL (NTOTAL, N, VALUE, S, C) C * * * * * * * * * * * * * * * * * * * * * * * * * * C APPLY AN ESSENTIAL B.C. TO FULL SYMMETRIC EQS C S*D = C, D(N) = VALUE C * * * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8 (A-H,O-Z) DIMENSION S(NTOTAL,NTOTAL), C(NTOTAL) C C = FULL COLUMN MATRIX C N = DOF NUMBER OF CONSTRAINED PARAMETER C NTOTAL = TOTAL NUMBER OF EQUATIONS C S = FULL SQUARE MATRIX C VALUE = GIVEN VALUE OF DOF NUMBER N C NOTE: REACTION DATA ARE LOST DO 10 I = 1, NTOTAL C(I) = C(I) - VALUE*S(I,N) S(I,N) = 0.0 10 S(N,I) = 0.0 S(N,N) = 1.0 C(N) = VALUE RETURN END SUBROUTINE MODFY1 (NDFREE, MBW, L1, C1, SS, CC) C * * * * * * * * * * * * * * * * * * * * * * * * * * C APPLY TYPE 1 CONSTRAINT EQUATION MODIFICATIONS C IN UPPER HALF BANDWIDTH MODE C SS*DD = CC, DD(L1) = C1 C * * * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8(A-H,O-Z) DIMENSION SS(NDFREE,MBW), CC(NDFREE) C SS = RECTANGULAR MATRIX WITH UPPER HALF C BANDWIDTH OF SYMMETRIC SYSTEM EQUATIONS C CC = SYSTEM COLUMN MATRIX C L1 = SPECIFIED SYSTEM DEGREE OF FREEDOM NUMBER C C1 = SPECIFIED CONSTRAINT EQUATION COEFFICIENT C MBW = MAX. HALF BANDWIDTH OF SYSTEM C NDFREE = TOTAL DEGREES OF FREEDOM OF SYSTEM PARAMETER ( ZERO = 0.0 ) M1 = MIN0 (L1,MBW) - 1 IF ( M1 .GT. 0 ) THEN DO 10 I = 1,M1 IROW = L1 - I ICOL = I + 1 IF ( C1 .NE. ZERO ) THEN CC(IROW) = CC(IROW) - C1*SS(IROW,ICOL) ENDIF 10 SS(IROW,ICOL) = ZERO ENDIF M1 = MIN0 ( (NDFREE + 1 - L1),MBW ) DO 20 I = 1,M1 IROW = L1 - 1 + I ICOL = I IF ( C1 .NE. ZERO ) THEN CC(IROW) = CC(IROW) - C1*SS(L1,ICOL) ENDIF 20 SS(L1,ICOL) = ZERO SS(L1,1) = 1.0 CC(L1) = C1 RETURN END SUBROUTINE MODFY2 (NDFREE,MBW,IBW,L1,L2,C1,C2,S,C) C * * * * * * * * * * * * * * * * * * * * * * * * * * C APPLY TYPE 2 CONSTRAINT MODIFICATIONS C IN UPPER HALF BANDWIDTH MODE C D(L1) + C1*D(L2) = C2 , S*D = C C * * * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8(A-H,O-Z) PARAMETER ( ZERO = 0.0 ) DIMENSION S(NDFREE,MBW), C(NDFREE) C NDFREE = TOTAL NUMBER OF SYSTEM DEGREES OF FREEDOM C IBW = ORIG. HALF BAND C MBW = MODIFIED HALF BAND C L1,L2 = SPECIFIED D.O.F. NUMBERS C C1,C2 = CONSTRAINT EQ COEFFS C S = SYS. EQ. SQ. MATRIX C C = SYS. EQ. COL. MATRIX C D = SYSTEM ARRAY OF DEGREES OF FREEDOM c write (6,*) NDFREE,MBW,IBW,L1,L2,C1,C2 C INITIAL CALCULATIONS CALL BANSUB (L1,L2,IB1,JB2) S12 = S(IB1,JB2) C11 = C(IB1) IROW1 = MAX0 (1,(L1-IBW+1)) IROW2 = MIN0 (NDFREE,(L1+IBW-1)) C SUBTRACT C1*COLUMN L1 FROM COLUMN L2 C SUBTRACT C2*COLUMN L1 FROM R.H.S. DO 10 I1 = IROW1, IROW2 CALL BANSUB (I1,L1,IB1,JB1) CALL BANSUB (I1,L2,IB2,JB2) S(IB2,JB2) = S(IB2,JB2) - C1*S(IB1,JB1) IF ( C2 .NE. ZERO ) THEN C(IB2) = C(IB2) - C2*S(IB1,JB1) ENDIF 10 S(IB1,JB1) = ZERO C SUBTRACT C1*ROW L1 FROM ROW L2 C ADD CONSTRAINT EQUATIONS S(L1,1) = 1.0 S(L2,1) = S(L2,1) - C1*S12 + C1*C1 C(L1) = C2 C(L2) = C(L2) - C1*C11 + C1*C2 CALL BANSUB (L1,L2,IB1,JB2) S(IB1,JB2) = C1 C UPON EXIT CONSTRAINT HAS INCREASED BANDWIDTH IBW = IBW + IABS( L2 - L1 ) c write (6,*) NDFREE,MBW,IBW,L1,L2,C1,C2 c IF ( IBW .GT. MBW ) STOP ' FATAL ERROR IN MODFY2' RETURN END SUBROUTINE MODFY3 (NDFREE,MBW,IBW,L1,L2,L3,C1, 1 C2,C3,S,C) C * * * * * * * * * * * * * * * * * * * * * * * * * * C APPLY TYPE 3 CONSTRAINT MODIFICATIONS C IN UPPER HALF BANDWIDTH MODE C D(L1) + C1*D(L2) + C2*D(L3) = C3 ,S*D=C C * * * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8(A-H,O-Z) DIMENSION S(NDFREE,MBW), C(NDFREE) C NDFREE = TOTAL NO OF SYSTEM DEGREES OF FREEDOM C IBW = ORIG HALF BAND, MBW = MODIFIED HALF BAND C L1,L2,L3 = SPECIFIED DOF NUMBERS C C1,C2,C3 = CONSTRAINT EQ COEFFS C S = SYS EQ SQ MATRIX, C = SYS EQ COL MATRIX C D = SYSTEM ARRAY OF DEGREES OF FREEDOM ZERO = 0.0 C INITIAL CALCULATIONS CALL BANSUB (L1,L2,I1,I2) CALL BANSUB (L1,L3,J1,J3) CALL BANSUB (L2,L3,K2,K3) S22 = S(L1,1)*C1*C1+C1*C1+S(L2,1)-2.*C1*S(I1,I2) S23 = S(K2,K3)-C2*S(I1,I2)-C1*S(J1,J3)+C1*C2*S(L1,1)+C1*C2 S33 = S(L3,1)-2.*C2*S(J1,J3)+C2*C2*S(L1,1)+C2*C2 C22 = C(L2)-C3*S(I1,I2)-C1*C(L1)+C1*C3*(1.+S(L1,1)) C33 = C(L3)-C3*S(J1,J3)-C2*C(L1)+C2*C3*(1.+S(L1,1)) IF ( S22.LE.0.0 .OR. S33.LE.0.0 ) WRITE (NBUG,5) 5 FORMAT (' WARNING: ZERO DIAGONAL IN MODFY3') IROW1 = MAX0 (1,(L1-IBW+1)) IROW2 = MIN0 (NDFREE,(L1+IBW-1)) C SUBTRACT C1*COLUMN L1 FROM COLUMN L2 C SUBTRACT C2*COLUMN L1 FROM COLUMN L3 C SUBTRACT C3*COLUMN L1 FROM R.H.S. DO 10 K = IROW1,IROW2 CALL BANSUB (K,L1,I1,J1) CALL BANSUB (K,L2,I2,J2) CALL BANSUB (K,L3,I3,J3) C(I2) = C(I2) - C3*S(I1,J1) S(I2,J2) = S(I2,J2) - C1*S(I1,J1) S(I3,J3) = S(I3,J3) - C2*S(I1,J1) 10 S(I1,J1) = ZERO C ADD CONSTRAINT EQUATIONS C(L1) = C3 C(L2) = C22 C(L3) = C33 S(L1,1) = 1.0 S(L2,1) = S22 S(L3,1) = S33 CALL BANSUB(L1,L2,I1,J2) S(I1,J2) = C1 CALL BANSUB(L1,L3,I1,J3) S(I1,J3) = C2 CALL BANSUB(L2,L3,I2,J3) S(I2,J3) = S23 C UPON EXIT CONSTRAINT HAS INCREASED BANDWIDTH MIN = MIN0 (L1,L2,L3) MAX = MAX0 (L1,L2,L3) IBW = IBW + MAX - MIN IF ( IBW .GT. MBW ) STOP ' FATAL ERROR IN MODFY3' RETURN END SUBROUTINE MODLFL (NDFREE, S, C, NCD, NDX, A) C * * * * * * * * * * * * * * * * * * * * * * * * * * * * C APPLY LINEAR CONSTRAINTS TO FULL SYMMETRIC EQUATIONS C S*D = C WITH CONSTRAINT C D(NDX(1))+A(1)*D(NDX(2))+...A(NCD-1)*D(NDX(NCD))=A(NCD) C * * * * * * * * * * * * * * * * * * * * * * * * * * * * PARAMETER ( ZERO = 0.0, ONE = 1.0 ) DIMENSION S(NDFREE,NDFREE), C(NDFREE), NDX(NCD), A(NCD) C NCD = TOTAL NUMBER OF DOF IN CONSTRAINT EQUATION C NDFREE = TOTAL NUMBER OF DEGREES OF FREEDOM C NDX(I) = SYS DOF NOS OF CONSTRAINT TERM I C NR = REDUNDANT DEGREE OF FREEDOM = NDX(1) C A(J) = NORMALIZED COEFF OF (J+1) TERM, A0 = 1.0 C C = SYSTEM COLUMN MATRIX : Sii Sir Sid : :Di: :Ci: C S = SYSTEM SQUARE MATRIX : Sri Srr Srd : :Dr:=:Cr: C r-redundant, d-dependent : Sdi Sdr Sdd : :Dd: :Cd: E = A(NCD) NR = NDX(1) SRR = S(NR,NR) SRRP1 = SRR + ONE CR = C(NR) ESC = E*SRRP1 - CR C FORM MODIFIED COLUMN MATRIX, Cx = Cx - E*Sxr IF ( E .NE. ZERO ) THEN DO 10 I = 1,NDFREE 10 C(I) = C(I) - E*S(I,NR) ENDIF C ADDITIONAL COLUMN CHANGES FOR Cd AND Cr IF ( NCD .GT. 1 .AND. ESC .NE. ZERO ) THEN DO 30 K = 2,NCD 30 C( NDX(K) ) = C( NDX(K) ) + A(K-1)*ESC ENDIF C(NR) = E C *** SQUARE MATRIX COLUMN MODIFICATIONS *** IF ( NCD .GT. 1 ) THEN C FORM Sid, BEGIN Sdd DO 60 K = 2,NCD J = NDX(K) DO 50 I = 1,NDFREE 50 S(I,J) = S(I,J) - S(I,NR)*A(K-1) 60 CONTINUE C COMPLETE Sdd DO 80 K = 2,NCD I = NDX(K) DO 70 L = 2,NCD J = NDX(L) 70 S(I,J) = S(I,J) + SRRP1*A(K-1)*A(L-1) - A(K-1)*S(J,NR) 80 CONTINUE C ROW OPERATIONS DO 85 K = 2,NCD I = NDX(K) DO 75 L = 2,NCD J = NDX(L) 75 S(J,I) = S(I,J) 85 CONTINUE DO 65 K = 2,NCD J = NDX(K) DO 55 I = 1,NDFREE 55 S(J,I) = S(I,J) 65 CONTINUE ENDIF C *** INSERT CONSTRAINT EQUATION *** C WARNING: NEXT LOOP NOT VALID FOR COUPLED LINEAR CONSTRAINTS DO 90 I = 1,NDFREE S(I,NR) = ZERO 90 S(NR,I) = ZERO S(NR,NR) = 1.0 IF ( NCD .GT. 1 ) THEN DO 100 K = 2,NCD I = NDX(K) S(I,NR) = A(K-1) 100 S(NR,I) = A(K-1) C *** MODIFICATIONS COMPLETED, CHECK DIAGONAL *** DO 110 K = 2,NCD I = NDX(K) IF ( S(I,I) .LE. ZERO ) WRITE (6,*) 1 'Negative diagonal for constraint set', NDX 110 CONTINUE ENDIF RETURN END SUBROUTINE MSMULT (S, A, M, N) C * * * * * * * * * * * * * * * * * * * * * * * * * * C MULTIPLY A MATRIX BY A SCALAR, AS(M,N) = S*A(M,N) C * * * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8(A-H,O-Z) DIMENSION A(1) MN = M*N DO 10 I = 1,MN 10 A(I) = A(I)*S RETURN END SUBROUTINE MTMULT (ALM, BLN, CMN, L, M, N) C * * * * * * * * * * * * * * * * * * * * * * * * * * C TRANPOSE MATRIX MULTIPLICATION C C(M,N) = (A(L,M))T*B(L,N) C * * * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8 (A-H,O-Z) PARAMETER ( ZERO = 0.0 ) DIMENSION ALM(L,M), BLN(L,N), CMN(M,N) DO 30 I = 1,N DO 20 J = 1,M SUM = ZERO DO 10 K = 1,L BLNKI = BLN(K,I) IF ( BLNKI.EQ.ZERO ) GO TO 10 ALMKJ = ALM(K,J) IF ( ALMKJ.EQ.ZERO ) GO TO 10 SUM = SUM + ALMKJ*BLNKI 10 CONTINUE CMN(J,I) = SUM 20 CONTINUE 30 CONTINUE RETURN END SUBROUTINE NGRAND (WT, DET, H, DGH, XPT, N, NSPACE, 1 NELFRE, COL, SQ, NTAPE1) C * * * * * * * * * * * * * * * * * * * * * * * * * * C PROBLEM DEPENDENT INTEGRAND EVALUATION IN C AN ISOPARAMETRIC OR SUBPARAMETRIC ELEMENT C * * * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8 (A-H,O-Z) DIMENSION COL(NELFRE), SQ(NELFRE,NELFRE), 1 H(nelfre), DGH(NSPACE,nelfre), XPT(NSPACE) cb 1 H(N), DGH(NSPACE,N), XPT(NSPACE) C N = NUMBER OF NODES PER ELEMENT C NSPACE = NUMBER OF SPATIAL DIMENSIONS C NELFRE = NUMBER OF ELEMENT DEGREES OF FREEDOM C H = ELEMENT INTERPOLATION FUNCTIONS C DGH = GLOBAL DERIVATIVES OF H C XPT = GLOBAL COORDS OF THE POINT C WT = QUADRATURE WEIGHT AT POINT C DET = JACOBIAN DETERMINATE AT POINT C COL = PROB DEP COLUMN MATRIX INTEGRAND C SQ = PROB DEP SQUARE MATRIX INTEGRAND C NTAPE1 = STORAGE UNIT FOR POST SOLUTION DATA C .................................................... C *** NGRAND PROBLEM DEPENDENT STATEMENTS FOLLOW *** C .................................................... RETURN END SUBROUTINE PENLTY (NPFRE, CEQ, CP, SP, WT) C * * * * * * * * * * * * * * * * * * * * * * * * * * C DEFINE CONSTRAINT PENALTY SQ AND COL MATRICES C * * * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8 (A-H,O-Z) DIMENSION CEQ(NPFRE), CP(NPFRE), SP(NPFRE,NPFRE) C NPFRE = NO DOF IN CONSTRAINT EQUATION C CEQ(I) = CONSTR EQ COEFFICIENT I+1 C CP = CONSTRAINT COLUMN MATRIX C SP = CONSTRAINT SQUARE MATRIX C WT = PENALTY WEIGHT FACTOR C INITIAL CALCULATIONS CP(1) = 1.0 TEMP = CEQ(NPFRE) IF ( NPFRE .GT. 1 ) THEN DO 10 I = 2,NPFRE 10 CP(I) = CEQ(I-1) ENDIF C CALCULATE LEAST SQ CONSTRAINT FORMS DO 40 I = 1, NPFRE DO 30 J = 1, NPFRE 30 SP(J,I) = WT*CP(I)*CP(J) 40 CONTINUE DO 50 I = 1, NPFRE 50 CP(I) = CP(I)*TEMP*WT RETURN END SUBROUTINE PENMOD (MAXACT, NUMCE, NREQ, NDXC, CEQ, 1 CP, SP, CC, SS, NDFREE, MAXBAN) C * * * * * * * * * * * * * * * * * * * * * * * * * * C APPLY CONSTRAINT EQS BY PENALTY MODIFICATIONS C * * * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8 (A-H,O-Z) DIMENSION SS(NDFREE,MAXBAN), CC(NDFREE), CP(MAXACT), 1 SP(MAXACT,MAXACT), CEQ(MAXACT,NUMCE), 2 NDXC(MAXACT,NUMCE), NREQ(MAXACT) DATA FACTOR / 1.D12 / C MAXACT = NUMBER OF ACTIVE CONSTRAINT TYPES C NUMCE = NUMBER OF CONSTRAINT EQUATIONS C NREQ(I) = NUMBER OF CONSTR EQS OF TYPE I C NDXC(I,J) = DOF NUMBER OF TERM I OF EQ J C CEQ(I,J) = COEFF TERM I+1 OF EQ J C CP = PENALTY SQUARE MATRIX C SP = PENALTY SQUARE MATRIX C SS = SYSTEM SQ MATRIX UPPER HALF BANDWIDTH C CC = SYSTEM COLUMN MATRIX C FACTOR = PENALTY WEIGHT FACTOR IEQ = 0 C FIND NUNBER OF EQS OF EACH TYPE DO 30 IC = 1, MAXACT NTEST = NREQ(IC) IF ( NTEST .GT. 0 ) THEN C BEST TO CALL MODFY1 IF IC=1 IF ( IC .GT.1 ) FACTOR = 1.0D3 C LOOP OVER NO EQS DO 20 J = 1, NTEST IEQ = IEQ + 1 C SELECT AVERAGE WEIGHT WT = 0.0 DO 10 K = 1, IC 10 WT = WT + SS(NDXC(K,IEQ),1) WT = WT*FACTOR/IC C EXTRACT COEFF AND FORM LEAST SQ MATRICES CALL PENLTY (IC,CEQ(1,IEQ),CP,SP,WT) C EXTRACT DOF NOS AND ADD PENALTY TO SYS EQS CALL STORCL (NDFREE,IC,NDXC(1,IEQ),CP,CC) CALL STORSQ (NDFREE,MAXBAN,IC,NDXC(1,IEQ),SP,SS) 20 CONTINUE ENDIF 30 CONTINUE RETURN END SUBROUTINE PLTSET (FLTMIS) C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C EXTRACT PLOTTER PARAMETERS FROM MISC. DATA STORAGE C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C REFER TO STANDARD CALCOMP MANUALS CDP IMPLICIT REAL*8 (A-H,O-Z) DIMENSION FLTMIS(6) COMMON /PLTKAL/ XLEN, YLEN, FIRSTX, FIRSTY, DELTAX, DELTAY, 1 XLAST, YLAST DATA KALPLT / 1 / C XLEN, YLEN = PLOT LENGTH IN INCHES C FIRSTX, FIRSTY = GLOBAL COORDINATES OF PLOT ORIGIN C DELTAX, DELTAY = CHANGE IN GLOBAL COORD. PER INCH OF PLOT C USE FIRST SIX LOCATIONS FOR PLOTTER XLEN = FLTMIS(1) YLEN = FLTMIS(2) FIRSTX = FLTMIS(3) FIRSTY = FLTMIS(4) DELTAX = FLTMIS(5) DELTAY = FLTMIS(6) XLAST = FIRSTX + XLEN*DELTAX YLAST = FIRSTY + YLEN*DELTAY WRITE (6,5000) XLEN, YLEN, FIRSTX, FIRSTY, DELTAX, DELTAY 5000 FORMAT ( /, '* SUPPLIED PLOT PARAMETERS *',/, 1'X-LENGTH...',1PE13.3,' Y-LENGTH...',1PE13.3,/, 2'FIRST-X....',1PE13.3,' FIRST-Y....',1PE13.3,/, 3'DELTA-X....',1PE13.3,' DELTA-Y....',1PE13.3,/) IF ( KALPLT .EQ. 0 ) RETURN C--> ON THE FIRST CALL OPEN THE PLOT FILE KALPLT = 0 C INSTALLATION DEPENDENT STATEMENTS FOLLOW CPLT CALL PLOTS (0,0,0,'MODEL') RETURN END SUBROUTINE POST ( M, NE, NG, NDFREE, NODES, LNODE, INDEX, 1 DD, N, NSPACE, NELFRE, NRB, NQP, NGEOM, NPARM, NNPFIX, 2 NNPFLO, MISCFX, MISCFL, NLPFIX, NLPFLO, COORD, S, C, H, 3 DGH, B, E, EB, STRAIN, STRAN0, STRESS, BODY, PT, WT, 4 XYZ, DLH, G, DLG, AJ, AJINV, HINTG, D, PRTLPT, FLTMIS, 5 ELPROP, PRTMAT, MISFIX, LSHAPE, LPROP, LPPROP, 6 NTAPE1, NTAPE2, NTAPE3, NTAPE4, NTAPE5, IT, NITER, 7 LTYPE, NLTYPE, LTDATA, GPT, GWT, LHOMO, FLTNP, FLTEL, 8 NPFIX, LPFIX, USEREL, USERPT, AVE, IADD ) C * * * * * * * * * * * * * * * * * * * * * * * * * * * * C ELEMENT LEVEL POST-SOLUTION CALCULATIONS C * * * * * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8 (A-H,O-Z) C Material option for future uses. Add to arguments, etc. PARAMETER ( NMAT = 0 ) DATA LASTLT / 0 / C ALWAYS USED DIMENSION COORD(N,NSPACE), S(NELFRE,NELFRE), DD(NDFREE), 1 D(NELFRE), NODES(NE,N), LNODE(N), INDEX(NELFRE), 2 LTYPE(NE), LTDATA(6,NLTYPE) C C USUALLY USED cb DIMENSION C(NELFRE), H(N,0:NQP), DGH(NSPACE,N), B(NRB,NELFRE), DIMENSION C(NELFRE), H(nelfre,0:NQP), DGH(NSPACE,nelfre), 3 B(NRB,NELFRE), 1 E(NRB,NRB), EB(NRB,NELFRE), STRAIN(NRB+2), 2 STRAN0(NRB), STRESS(NRB+2), BODY(NSPACE) C C OPTIONAL FOR NUMERICAL INTEGRATION cb DIMENSION PT(NPARM,0:NQP), WT(0:NQP), DLH(NSPACE,N,0:NQP), cb 2 AJINV(NSPACE,NSPACE), HINTG(N), XYZ(NSPACE), DIMENSION PT(NPARM,0:NQP), WT(0:NQP), DLH(NSPACE,nelfre,0:NQP), 1 G(NGEOM), DLG(NPARM,NGEOM), AJ(NSPACE,NSPACE), 2 AJINV(NSPACE,NSPACE), HINTG(nelfre), XYZ(NSPACE), 3 GPT(0:NQP), GWT(0:NQP) C C OPTIONAL PROPERTY VALUES cb DIMENSION D(NELFRE), PRTLPT(N,0:NNPFLO), FLTMIS(0:MISCFL), DIMENSION PRTLPT(N,0:NNPFLO), FLTMIS(0:MISCFL), 1 ELPROP(0:NLPFLO), PRTMAT(0:NLPFLO), 2 MISFIX(0:MISCFX), LPROP(0:NLPFIX), 3 LPPROP(0:NNPFIX) DIMENSION FLTNP(M,0:NNPFLO), FLTEL(NE,0:NLPFLO), 1 NPFIX(M,0:NNPFIX), LPFIX(NE,0:NLPFIX) C C OPTIONAL USER APPLICATION AT NODE OR ELEMENT DIMENSION USERPT(NG), USEREL(NG,N) C OPTIONAL FOR NODAL AVERAGING DIMENSION AVE(0:M,NRB+2), IADD(0:M) C C VARIABLES: C AJ = JACOBIAN C AJINV = JACOBIAN INVERSE C AVE = AVERAGED STRESS VECTOR AT SYSTEM NODES, SEE IADD C B = STRAIN-DISPLACEMENT (GRADIENT) MATRIX C BODY = BODY FORCE VECTOR C COORD = SPATIAL COORDINATES OF ELEMENT'S NODES C D = NODAL PARAMETERS ASSOCIATED WITH AN ELEMENT C DD = ARRAY OF SYSTEM DEGREES OF FREEDOM C DGH = GLOBAL DERIVATIVES INTERPOLATION FUNCTIONS C DLG = LOCAL DERIVATIVES GEOMETRIC INTERPOLATION C DLH = LOCAL DERIVATIVES INTERPOLATION FUNCTIONS C E = CONSTITUTIVE MATRIX C EB = PRODUCT OF E*B C ELPROP = ELEMENT ARRAY OF FLOATING PT PROPERTIES C FLTMIS = SYSTEM STORAGE OF FLOATING PT MISC PROP C G = GEOMETRIC INTERPOLATION FUNCTIONS C H = SOLUTION INTERPOLATION FUNCTIONS C HINTG = INTEGRAL OF INTERPOLATION FUNCTIONS C IADD = COUNTER ON NODAL ENTRIES IN AVE. AVE = AVE/IADD C INDEX = SYSTEM DOF NOS ASSOCIATED WITH ELEMENT C IT = CURRENT ITERATION NUMBER C LNODE = THE N ELEMENT INCIDENCES OF THE ELEMENT C LPPROP = INTEGER PROPERTIES AT EACH ELEMENT NODE C LPROP = ARRAY INTEGER POINT ELEMENT PROPERTIES C M = TOTAL NUMBER OF NODES C MISFIX = MISCELLANEOUS INTEGER SYSTEM PROPERTIES C N = NUMBER OF NODES PER ELEMENT C NDFREE = TOTAL NUMBER OF SYSTEM DEGREES OF FREEDOM C NE = NUMBER OF ELEMENTS IN SYSTEM C NELFRE = NUMBER OF DEGREES OF FREEDOM PER ELEMENT C NG = NUMBERS PARAMETERS PER NODE C NGEOM = NUMBER OF GEOMETRY NODES C NITER = MAX NUMBER OF ITERATIONS C NMAT = NUMBER OF MATERIAL TYPES C NODES = ELEMENT INCIDENCES OF ALL ELEMENTS C NPARM = DIMENSION OF PARAMWETRIC SPACE C NQP = NUMBER OF QUADRATURE POINTS C NRB = NUMBER OF ROWS IN B AND E MATRICES C NSPACE = DIMENSION OF SPACE C NTAPE1 = UNIT FOR POST SOLUTION MATRICES STORAGE C NTAPE2,3,4 = OPTIONAL UNITS FOR USER (USED WHEN > 0) C PRTLPT = REAL PROPERTIES AT ELEMENT NODES C PRTMAT = REAL ELEM PROPERTIES BASED ON MATERIAL NUMBER C PT = QUADRATURE COORDINATES C S = ELEMENT SQUARE MATRIX C STRAIN = STRAIN OR GRADIENT VECTOR C STRAN0 = INITIAL STRAIN OR GRADIENT VECTOR C STRESS = STRESS VECTOR C USEREL = (USER CHOICE) ELEMENT APPLICATION RESULT C USERPT = (USER CHOICE) NODAL APPLICATION RESULT C WT = QUADRATURE WEIGHTS C XYZ = SPACE COORDINATES AT A POINT C NTAPE1 MUST BE > 0 IF ( NTAPE1 .GT. 0 ) THEN REWIND NTAPE1 ELSE STOP 'NO NTAPE1 IN POST' ENDIF C C--> LOOP OVER ELEMENTS LPTEST = NLPFIX + NLPFLO DO 10 IE = 1, NE C--> GET ELEMENT TYPE NUMBER LT = 1 IF ( NLTYPE .GT. 1 ) LT = LTYPE(IE) C SAME AS LAST TYPE ? IF ( LT .NE. LASTLT ) THEN LASTLT = LT C GET CONTROLS FOR THIS TYPE CALL GETLT (LT, NLTYPE, LTDATA, LTN, LTQP, LTGEOM, 1 LTPARM, LTSHAP, LTUSER ) LTFREE = LTN*NG C--> GET QUADRATURE RULE FOR ELEMENT TYPE AND SHAPE IF ( LTQP .GT. 0 ) CALL GETQD (LTSHAP, LTQP, NSPACE, 1 GPT, GWT, PT, WT) ENDIF C--> EXTRACT ELEMENT NODE NUMBERS CALL LNODES (IE, NE, LTN, NODES, LNODE) C--> CALCULATE DEGREE OF FREEDOM NUMBERS CALL INDXEL (LTN, LTFREE, NG, LNODE, INDEX) C--> EXTRACT NODAL PARAMETERS OF THE ELEMENT CALL ELFRE (NDFREE, LTFREE, D, DD, INDEX) C--> EXTRACT NODAL POINT PROPERTIES (IF ANY) IF ( NNPFLO .GT. 0 ) CALL LPTPRT (N, M, NNPFLO, FLTNP, 1 PRTLPT, NNPFIX, NPFIX, LPPROP, LNODE, NHOMO) C--> EXTRACT ELEMENT PROPERTIES (IF ANY) IF ( LPTEST .GT. 0 ) CALL ELPRTY (IE, LHOMO, NE, NLPFIX, 1 NLPFLO, LPFIX, FLTEL, LPROP, ELPROP) C--> EXTRACT MATERIAL PROPERTIES (IF ANY) IF ( NMAT .GT. 0 ) CALL MATPRT (NMAT, NLPFLO, MISCFL, 1 FLTMIS,PRTMAT) C C--> PERFORM PROBLEM DEPENDENT CALCULATIONS AND OUTPUT C CALL POSTEL (LTN, NSPACE, LTFREE, NRB, LTQP, LTGEOM, 1 LTPARM, NNPFIX, NNPFLO, MISCFX, MISCFL, NLPFIX, 2 NLPFLO, COORD, S, C, H, DGH, B, E, EB, STRAIN, 3 STRAN0, STRESS, BODY, PT, WT, XYZ, DLH, G, DLG, 4 AJ, AJINV, HINTG, D, PRTLPT, FLTMIS, ELPROP, 5 PRTMAT, MISFIX, LTSHAP, LPROP, LPPROP, NTAPE1, 6 NTAPE2, NTAPE3, NTAPE4, NTAPE5, IT, NITER, IE, NE, 7 LNODE, NG, USEREL, USERPT, AVE, IADD, M ) 10 CONTINUE RETURN END SUBROUTINE POSTEL (N, NSPACE, NELFRE, NRB, NQP, NGEOM, 1 NPARM, NNPFIX, NNPFLO, MISCFX, MISCFL, NLPFIX, 2 NLPFLO, COORD, S, C, H, DGH, B, E, EB, STRAIN, 3 STRAN0, STRESS, BODY, PT, WT, XYZ, DLH, G, DLG, 4 AJ, AJINV, HINTG, D, PRTLPT, FLTMIS, ELPROP, 5 PRTMAT, MISFIX, LSHAPE, LPROP, LPPROP, NTAPE1, NTAPE2, 6 NTAPE3, NTAPE4, NTAPE5, IT, NITER, IE, NE, LNODE, NG ) C * * * * * * * * * * * * * * * * * * * * * * * * * * * * C ELEMENT LEVEL POST-SOLUTION CALCULATIONS C * * * * * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8 (A-H,O-Z) C ALWAYS USED DIMENSION COORD(N,NSPACE), S(NELFRE,NELFRE) C USUALLY USED cb DIMENSION C(NELFRE), H(N), DGH(NSPACE,N), B(NRB,NELFRE), DIMENSION C(NELFRE), H(nelfre), DGH(NSPACE,nelfre), 1 B(NRB,NELFRE), 1 E(NRB,NRB), EB(NRB,NELFRE), STRAIN(NRB+2), 2 STRAN0(NRB), STRESS(NRB+2), BODY(NSPACE) C OPTIONAL FOR NUMERICAL INTEGRATION cb DIMENSION PT(NPARM,0:NQP), WT(0:NQP), DLH(NSPACE,N), cb 2 AJINV(NSPACE,NSPACE), HINTG(N), LNODE(N), DIMENSION PT(NPARM,0:NQP), WT(0:NQP), DLH(NSPACE,nelfre), 1 G(NGEOM), DLG(NPARM,NGEOM), AJ(NSPACE,NSPACE), 2 AJINV(NSPACE,NSPACE), HINTG(nelfre), LNODE(N), 3 XYZ(NSPACE) C OPTIONAL PROPERTY AND SOLUTION VALUES DIMENSION D(NELFRE), PRTLPT(N,0:NNPFLO), FLTMIS(0:MISCFL), 1 ELPROP(0:NLPFLO), 2 PRTMAT(0:NLPFLO), MISFIX(0:MISCFX), 3 LPROP(0:NLPFIX), 4 LPPROP(0:NNPFIX) C VARIABLES: C AJ = JACOBIAN C AJINV = JACOBIAN INVERSE C B = STRAIN-DISPLACEMENT (GRADIENT) MATRIX C BODY = BODY FORCE VECTOR C COORD = SPATIAL COORDINATES OF ELEMENT'S NODES C D = NODAL PARAMETERS ASSOCIATED WITH AN ELEMENT C DGH = GLOBAL DERIVATIVES INTERPOLATION FUNCTIONS C DLG = LOCAL DERIVATIVES GEOMETRIC INTERPOLATION C DLH = LOCAL DERIVATIVES INTERPOLATION FUNCTIONS C E = CONSTITUTIVE MATRIX C EB = PRODUCT OF E*B C ELPROP = ELEMENT ARRAY OF FLOATING PT PROPERTIES C FLTMIS = SYSTEM STORAGE OF FLOATING PT MISC PROP C G = GEOMETRIC INTERPOLATION FUNCTIONS C H = SOLUTION INTERPOLATION FUNCTIONS C HINTG = INTEGRAL OF INTERPOLATION FUNCTIONS C IT = CURRENT ITERATION NUMBER C LPPROP = INTEGER PROPERTIES AT EACH ELEMENT NODE C LPROP = ARRAY INTEGER POINT ELEMENT PROPERTIES C MISFIX = MISCELLANEOUS INTEGER SYSTEM PROPERTIES C N = NUMBER OF NODES PER ELEMENT C NELFRE = NUMBER OF DEGREES OF FREEDOM PER ELEMENT C NGEOM = NUMBER OF GEOMETRY NODES C NITER = MAX NUMBER OF ITERATIONS C NMAT = NUMBER OF MATERIAL TYPES C NPARM = DIMENSION OF PARAMWETRIC SPACE C NQP = NUMBER OF QUADRATURE POINTS C NRB = NUMBER OF ROWS IN B AND E MATRICES C NSPACE = DIMENSION OF SPACE C NTAPE1 = UNIT FOR POST SOLUTION MATRICES STORAGE C NTAPE2,3,4 = OPTIONAL UNITS FOR USER (USED WHEN > 0) C PRTLPT = REAL PROPERTIES AT ELEMENT NODES C PRTMAT = REAL ELEM PROPERTIES BASED ON MATERIAL NUMBER C PT = QUADRATURE COORDINATES C S = ELEMENT SQUARE MATRIX C STRAIN = STRAIN OR GRADIENT VECTOR C STRAN0 = INITIAL STRAIN OR GRADIENT VECTOR C STRESS = STRESS VECTOR C WT = QUADRATURE WEIGHTS C XYZ = SPACE COORDINATES AT A POINT C .................................................... C *** POSTEL PROBLEM DEPENDENT STATEMENTS FOLLOW *** C .................................................... DATA KODE / 1 / IF ( KODE .EQ. 1 ) THEN KODE = 0 C--> WRITE GRADIENT HEADINGS WRITE (6,1000) 1000 FORMAT ( /, '** ELEMENT GRADIENTS **',/, A 'ELEMENT GRADIENT' ) ENDIF C--> READ GRADIENT MATRIX DATA OFF NTAPE1 FROM ELPOST DO 10 IQ = 1,NQP READ (NTAPE1) DGH C ---> CALCULATE GRADIENT, STRESS = DGH*D CALL MMULT (DGH,D,STRESS,NRB,NELFRE,1) WRITE (6,1010) IE, (STRESS(K), K = 1, 1) 1010 FORMAT (I5, 4X, 1PE12.5, 4X, 1PE12.5 ) 10 CONTINUE RETURN END SUBROUTINE PTCODE (JPT, NG, KODE, KODES) C * * * * * * * * * * * * * * * * * * * * * * * * * * C EXTRACT B.C. INDICATORS AT NODE NUMBER JPT C * * * * * * * * * * * * * * * * * * * * * * * * * * DIMENSION KODES(NG) C JPT = NODE NO. C NG = NO. PARAMETERS PER NODE C KODE = (NG) DIGIT INTEGER CONTAINING BC INDICATORS C KODES = VECTOR CONTAINING NG INTEGER CODES (0 OR I) C 0 IMPLIES NO B. C. C I IMPLIES A B. C. OF TYPE I NGPLUS = NG + 1 IOLD = KODE ISUM = 0 DO 10 I = 1,NG II = NGPLUS - I INEW = IOLD/10 IK = IOLD - INEW*10 ISUM = ISUM + IK*10**(I-1) IOLD = INEW 10 KODES(II) = IK C WAS DATA RIGHT JUSTIFIED? IF ( KODE .GT. ISUM ) WRITE (NBUG,*) 1 'WARNING,BC NOT RIGHT JUSTIFIED AT NODE', JPT RETURN END SUBROUTINE PTCORD (IPT, M, NSPACE, X, COORD) C * * * * * * * * * * * * * * * * * * * * * * * * * C EXTRACT COORDINATES OF POINT NUMBER IPT C * * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8(A-H,O-Z) DIMENSION X(M,NSPACE), COORD(1,NSPACE) C X = SPATIAL COORDINATES OF ALL SYSTEM NODES C COORD = SPATIAL COORDINATES OF THE NODE C M = TOTAL NUMBER OF NODES IN SYSTEM C N = NUMBER OF NODES PER ELEMENT C NSPACE = DIMENSION OF THE SPACE DO 10 J = 1, NSPACE 10 COORD(1,J) = X(IPT,J) RETURN END SUBROUTINE RADAU (N, P, W) C * * * * * * * * * * * * * * * * * * * * * * * * * * * * C RADAU QUADRATURE ABSCISSAE AND WEIGHTS FOR UNIT TRIANGLE C * * * * * * * * * * * * * * * * * * * * * * * * * * * * PARAMETER ( NMAX = 16 ) DIMENSION P(2,0:N), W(0:N) C N = TOTAL NUMBER OF QUADRATURE POINTS C P(1,I) = ABSCISSAE IN R-DIRECTION C P(2,I) = ABSCISSAE IN S-DIRECTION C W(I) = CORRESPONDING WEIGHTS C NMAX = MAXIMUM DEGREE TABULATED HEREIN NGP = N IF ( N .GT. NMAX ) THEN WRITE (NPRT,*) 'WARNING, RADAU N SET TO', NMAX NGP = NMAX ENDIF IF ( NGP .EQ. 1 ) THEN C M = NGP = 1 P(1,1) = 0.333333333333 P(2,1) = 0.333333333333 W(1) = 0.5 RETURN ENDIF IF ( NGP .EQ. 4 ) THEN C M = 2, NGP = M*M W(1) = 0.0909793091 W(2) = 0.1590206909 W(3) = 0.0909793091 W(4) = 0.1590206909 P(1,1) = 0.2800199155 P(1,2) = 0.6663902460 P(1,3) = 0.0750311102 P(1,4) = 0.1785587283 P(2,1) = 0.0750311102 P(2,2) = 0.1785587283 P(2,3) = 0.2800199155 P(2,4) = 0.6663902460 RETURN ENDIF IF ( NGP .EQ. 9 ) THEN C M = 3, NGP = M*M W(1) = 0.019396383304 W(2) = 0.063678085097 W(3) = 0.055814420490 W(4) = 0.031034213285 W(5) = 0.101884936154 W(6) = 0.089303072783 W(7) = 0.019396383304 W(8) = 0.063678085097 W(9) = 0.055814420490 P(1,1) = 0.18840940591 P(1,2) = 0.52397906774 P(1,3) = 0.80869438567 P(1,4) = 0.10617026910 P(1,5) = 0.29526656780 P(1,6) = 0.45570602025 P(1,7) = 0.02393113229 P(1,8) = 0.06655406786 P(1,9) = 0.10271765483 P(2,1) = 0.02393113229 P(2,2) = 0.06655406786 P(2,3) = 0.10271765483 P(2,4) = 0.10617026910 P(2,5) = 0.29526656780 P(2,6) = 0.45570602025 P(2,7) = 0.18840940591 P(2,8) = 0.52397906774 P(2,9) = 0.80869438567 RETURN ENDIF IF ( NGP .EQ. 16 ) THEN C M = 4, NGP = M*M W(1) = 0.005423225910 W(2) = 0.022584049287 W(3) = 0.035388067900 W(4) = 0.023568368199 W(5) = 0.010167259561 W(6) = 0.042339724518 W(7) = 0.066344216093 W(8) = 0.044185088522 W(9) = 0.010167259561 W(10) = 0.042339724518 W(11) = 0.066344216093 W(12) = 0.044185088522 W(13) = 0.005423225910 W(14) = 0.022584049287 W(15) = 0.035388067900 W(16) = 0.023568368199 P(1,1) = 0.13005607918 P(1,2) = 0.38749748338 P(1,3) = 0.67294686319 P(1,4) = 0.87742880935 P(1,5) = 0.09363778441 P(1,6) = 0.27899046348 P(1,7) = 0.48450832666 P(1,8) = 0.63173125166 P(1,9) = 0.04612207989 P(1,10) = 0.13741910412 P(1,11) = 0.23864865974 P(1,12) = 0.31116455224 P(1,13) = 0.00970378512 P(1,14) = 0.02891208422 P(1,15) = 0.05021012321 P(1,16) = 0.06546699455 P(2,1) = 0.00970378512 P(2,2) = 0.02891208422 P(2,3) = 0.05021012321 P(2,4) = 0.06546699455 P(2,5) = 0.04612207989 P(2,6) = 0.13741910412 P(2,7) = 0.23864865974 P(2,8) = 0.31116455224 P(2,9) = 0.09363778441 P(2,10) = 0.27899046348 P(2,11) = 0.48450832666 P(2,12) = 0.63173125166 P(2,13) = 0.13005607918 P(2,14) = 0.38749748338 P(2,15) = 0.67294686319 P(2,16) = 0.87742880935 ENDIF RETURN END SUBROUTINE REACT (NREACT, NDFREE, NG, DD) C * * * * * * * * * * * * * * * * * * * * * * ** C USE THE KNOWN SOLUTION, DD, TO COMPUTE THE C REACTIONS AT THE ESSENTIAL BOUNDARY CONDITIONS C FOR FULL SYMMETRIC EQUATIONS, SS*DD = CC C * * * * * * * * * * * * * * * * * * * * * * ** C SEE SUBROUTINE SAVFUL, SAVBAN, OR SAVSKY CDP IMPLICIT REAL*8 (A-H,O-Z) DIMENSION DD(NDFREE) C DD = COMPUTED SOLUTION VECTOR, SS*DD=CC C N = DOF NUMBER OF ESSENTIAL B.C. C NG = NUMBER OF DOF PER NODE C NREACT = SEQUENTIAL UNIT TO STORE REACTION DATA C NDFREE = TOTAL NUMBER OF EQUATIONS REWIND NREACT WRITE (6, 5000) 5000 FORMAT ( /, '*** REACTION RECOVERY ***', /, 1 'EQUATION REACTION NODE PARM') C READ EQUATION NUMBER, EXTRACT NODE AND PARAMETER 10 READ (NREACT, END=30) N IN = (N + NG -1)/NG IP = N - NG*(IN -1) R = 0.0 C READ THE N-TH ROW DO 20 J = 1, NDFREE READ (NREACT) SNJ 20 R = R + SNJ * DD(J) READ (NREACT) CN R = R - CN WRITE (6, 5010) N, R, IN, IP 5010 FORMAT ( I6, 1PE15.5, I5, I3 ) GO TO 10 30 RETURN END SUBROUTINE REACTEL (IE, N, NELFRE, NG, NTAPE, S, C, 1 D, USERPT, USEREL, LNODE, IOPT ) C * * * * * * * * * * * * * * * * * * * * * * * * * * * C GET REACTIONS (FLUXES) AT AN ELEMENTS NODES C * * * * * * * * * * * * * * * * * * * * * * * * * * * DIMENSION S(NELFRE,NELFRE), C(NELFRE), D(NELFRE), 1 USERPT(NG), USEREL(NG,N), LNODE(N) C C = ELEMENT COLUMN MATRIX C D = KNOWN SOLUTION CAUSING THE REACTIONS C IE = CURRENT ELEMENT NUMBER C IOPT = WRITE OPTION CODE 1-ONCE, 2-TWICE C LNODE = ELEMENT TOPOLOGY LIST C N = NUMBER OF NODES PER ELEMENT C NELFRE = NUMBER OF ELEMENT DOF, NG*N C NG = NUMBER OF GENERALIZED UNKNOWNS PER NODE C NTAPE = UNIT TO HOLDING S & C FROM ELEMENT IE C S = ELEMENT SQUARE MATRIX C USEREL = (USER CHOICE) ELEMENT APPLICATION RESULT C USERPT = (USER CHOICE) NODAL APPLICATION RESULT IF ( NTAPE .LT. 1 ) STOP 'INVALID UNIT IN REACTEL' C GIVE REACTIONS, R = S*D - C CALL ZEROA (NG,USERPT) CALL ZEROA (NG*N,USEREL) C READ STIFFNESS, AND SOURCE FOR ELEM REACTIONS C SINGLE READ IF ( IOPT .EQ. 1 ) THEN READ (NTAPE) S, C C DOUBLE READ ELSE IF ( IOPT .EQ. 2 ) THEN READ (NTAPE) S READ (NTAPE) C ENDIF DO 30 IN = 1, N IF ( IN .EQ. 1 ) THEN WRITE (6,*) ' ELEMENT', IE, ' REACTIONS' WRITE (6,*) ' NODE IDOF REACTION SOURCE' END IF DO 35 IG = 1, NG IROW = NG*(IN - 1) + IG USEREL(IG,1) = USEREL(IG,1) + C(IROW) ROW = 0.D0 DO 40 L = 1, NELFRE ROW = ROW + S(IROW,L)*D(L) 40 CONTINUE REACT = ROW - C(IROW) USERPT(IG) = USERPT(IG) + REACT WRITE (6,5030) LNODE(IN), IG, REACT, C(IROW) 5030 FORMAT( I5, I5, 1PE15.5, 1PE15.5 ) 35 CONTINUE 30 CONTINUE DO 50 IG = 1, NG WRITE (6,5050) IG, USERPT(IG), USEREL(IG,1) 50 CONTINUE 5050 FORMAT (' SUM:', I5, 1PE15.5, 1PE15.5 ) RETURN END SUBROUTINE REACTS (NREACT, NDFREE, NG, MODE, 1 DD, TOTAL) C * * * * * * * * * * * * * * * * * * * * * * * * * C--> COMPUTE REACTIONS IN BANDED MODE C * * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8 (A-H,O-Z) DIMENSION DD(NDFREE), TOTAL(NG) C DD = COMPUTED SOLUTION VECTOR, SS*DD=CC C MODE = STORAGE TYPE, !-BANDED 0-SKYLINE C N = DOF NUMBER OF ESSENTIAL B.C. C NG = NUMBER OF DOF PER NODE C NREACT = SEQUENTIAL UNIT TO STORE REACTION DATA C NDFREE = TOTAL NUMBER OF EQUATIONS C TOTAL = SUM OF REACTIONS FOR NG PARAMETERS IF ( NREACT .GT. 0 ) THEN REWIND NREACT WRITE (6, 5000) 5000 FORMAT ( /, '*** REACTION RECOVERY ***', /, 1 'NODE DOF REACTION EQUATION') DO 5 J = 1,NG TOTAL(J) = 0.0 5 CONTINUE ELSE STOP 'NO REACTION FILE, REACTS' ENDIF IF ( MODE .EQ. 1 ) THEN C BANDED MODE C READ NODE, PARAMETER, RANGE OF NON-ZERO TERMS 10 READ (NREACT, END=30) NODE, IG, J1, J2 c write(3,*) node,ig,j1,j2 R = 0.0 DO 20 J = J1, J2 READ (NREACT) SIJ c write(3,*) j, sij, dd(j) R = R + SIJ * DD(J) 20 CONTINUE READ (NREACT) CI c write(3,*) ci c write(3,*) r R = R - CI c write(3,*) r IE = NG*(NODE - 1) + IG WRITE (6,5010) NODE, IG, R, IE 5010 FORMAT ( 2 I4, 1X, 1PE11.4, I6 ) TOTAL(IG) = TOTAL(IG) + R GO TO 10 30 CONTINUE ELSE STOP 'SKYLINE MODE NOT SET IN REACTS' END IF WRITE (6,5020) 5020 FORMAT ('*RESULTANTS*',/, 1 'DOF SUM') DO 40 J = 1, NG WRITE (6,5030) J, TOTAL(J) 40 CONTINUE 5030 FORMAT ( I3, 2X, 1PE12.4 ) RETURN END SUBROUTINE RECT (NG, HR, HS, H) C * * * * * * * * * * * * * * * * * * * * * * C TENSOR PRODUCT INTERPOLATION FOR HERMITES C ON A RECTANGULAR ELEMENT C * * * * * * * * * * * * * * * * * * * * * * DIMENSION HR(2*NG), HS(2*NG), H(4*NG*NG), 1 IADD(4), JADD(4) DATA IADD / 0, 1, 1, 0 / DATA JADD / 0, 0, 1, 1 / C NG = NO. GENERALIZED DOF PER NODE IN 1-D MODEL C HR, HS = 1-D HERMITES ON 2 NODES C H = 2-D TENSOR PRODUCT FOR C^(NG-1) CONTINUITY C THE 4 NODES ARE NUMBERED COUNTERCLOCKWISE KOUNT = 0 C LOOP OVER RECTANGLE NODES DO 30 K = 1, 4 IPLUS = NG*IADD(K) JPLUS = NG*JADD(K) C LOOP LEFT TO RIGHT IN S-DIRECTION DO 20 J = 1, NG HSJ = HS(J+JPLUS) jj= (J+JPLUS) C LOOP LEFT TO RIGHT IN R-DIRECTION DO 10 I = 1, NG C FORM 2-D PRODUCT KOUNT = KOUNT + 1 ii=i+iplus H(KOUNT) = HR(I+IPLUS)*HSJ c write (6,*) kount,k,j,i,jj,ii,hsj,hr(ii),h(kount) 10 CONTINUE 20 CONTINUE 30 CONTINUE RETURN END SUBROUTINE RPRINT (A, NR, NC, IOPT) C * * * * * * * * * * * * * * * * * * * * * * * C PRINTING OF REAL MATRIX A(NR,NC) C * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8 (A) PARAMETER ( NPRT = 6, MAX = 10 ) DIMENSION A(1), NCOL(MAX) C A = REAL ARRAY C NR = NUMBER OF ROWS IN A C NC = NUMBER OF COLUMNS IN A C IOPT = 0 USE F FORMAT, OTHERWISE USE E FORMAT DO 50 J = 1, NC, MAX JL1 = J - 1 MAXCOL = 1 K = NC - JL1 MAXCOL = MIN0 (K,MAX) MXCLL1 = MAXCOL - 1 DO 10 L = 1, MAXCOL 10 NCOL(L) = L + JL1 WRITE (NPRT,5000) ( NCOL(N),N=1,MAXCOL ) 5000 FORMAT ('ROW/COL', I7, 9I10 ) DO 40 N = 1, NR NL = N + (J-1)*NR NH = NL + MXCLL1*NR IF ( IOPT ) 30,20,30 20 WRITE (NPRT,5010) N,( A(I),I=NL,NH,NR ) 5010 FORMAT (I4, 8F10.4) GO TO 40 30 WRITE (NPRT,5020) N,( A(I),I=NL,NH,NR ) 5020 FORMAT (I4, 10(1PE10.2) ) 40 CONTINUE 50 CONTINUE RETURN END SUBROUTINE SAVBAN (NREACT, M, NDFREE, NG, IBW, IBC, 1 INDEX, KODES, SS, CC) C * * * * * * * * * * * * * * * * * * * * * * * * * * * C--> SAVE INDEPENDENT REACTION EQUATIONS FROM BANDED MATRIX C * * * * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8 (A-H,O-Z) DIMENSION SS(NDFREE, IBW), CC(NDFREE), IBC(M), 1 INDEX(NG), KODES(NG) C NG = NUMBER OF DOF PER NODE C NREACT = SEQUENTIAL UNIT TO STORE REACTION DATA C NDFREE = TOTAL NUMBER OF EQUATIONS C LOOP OVER EQUATIONS FOR ESSENTIAL BC FLAG DO 30 J = 1, M IF ( IBC(J) .GT. 0 ) THEN CALL PTCODE (J, NG, IBC(J), KODES ) CALL INDXPT (J, NG, INDEX) DO 20 IG = 1, NG IF ( KODES(IG) .EQ. 1 ) THEN C FOUND TYPE ONE BC INDX = INDEX(IG) c write (3,*) indx c write (3,*) (ss(indx,ir), ir=1,ibw) J1 = MAX0( (INDX-IBW+1), 1 ) J2 = MIN0( (INDX+IBW-1), NDFREE ) C WRITE NODE, PARAMETER, RANGE OF NON-ZEROS WRITE (NREACT) J, IG, J1, J2 c write (3,* ) J, IG, J1, J2 C SAVE ROW OF EQUILIBRIUM EQ DO 10 JJ = J1, J2 CALL BANSUB (INDX, JJ, IROW, JCOL) c write (3,* ) SS(IROW,JCOL) WRITE (NREACT) SS(IROW,JCOL) 10 CONTINUE c write (3,* ) CC(INDX) WRITE (NREACT) CC(INDX) ENDIF 20 CONTINUE ENDIF 30 CONTINUE RETURN END SUBROUTINE SAVFUL (NREACT, M, NDFREE, NG, IBC, 1 INDEX, KODES, SS, CC) C * * * * * * * * * * * * * * * * * * * * * * * * * * * C--> SAVE INDEPENDENT REACTION EQUATIONS FROM FULL MATRIX C * * * * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8 (A-H,O-Z) DIMENSION SS(NDFREE, NDFREE), CC(NDFREE), IBC(M), 1 INDEX(NG), KODES(NG) C NG = NUMBER OF DOF PER NODE C NREACT = SEQUENTIAL UNIT TO STORE REACTION DATA C NDFREE = TOTAL NUMBER OF EQUATIONS C LOOP OVER EQUATIONS FOR ESSENTIAL BC FLAG DO 30 J = 1, M IF ( IBC(J) .GT. 0 ) THEN CALL PTCODE (J, NG, IBC(J), KODES ) CALL INDXPT (J, NG, INDEX) DO 20 IG = 1, NG IF ( KODES(IG) .EQ. 1 ) THEN C FOUND TYPE ONE BC INDX = INDEX(IG) J1 = 1 J2 = NDFREE C WRITE NODE, PARAMETER, RANGE OF NON-ZEROS WRITE (NREACT) J, IG, J1, J2 C SAVE ROW OF EQUILIBRIUM EQ DO 10 JJ = J1, J2 10 WRITE (NREACT) SS(INDX,JJ) WRITE (NREACT) CC(INDX) ENDIF 20 CONTINUE ENDIF 30 CONTINUE RETURN END SUBROUTINE SCHECK (H,N) C * * * * * * * * * * * * * * * * * * * * * * * * * * C NUMERICAL CHECKING OF N SHAPE FUNCTIONS, H, AT A C LOCAL POINT IN A C^0 ELEMENT C * * * * * * * * * * * * * * * * * * * * * * * * * * DOUBLE PRECISION ONE, SUM, TOL PARAMETER ( ONE = 1.0D0, TOL = 1.0D-7, NPRT = 6 ) DIMENSION H(N) C H = LOCAL COORDINATE INTERPOLATION FUNCTIONS C N = NUMBER OF SHAPE FUNCTIONS SUM = 0.0D0 DO 10 I = 1,N SUM = SUM + H(I) 10 CONTINUE IF ( DABS(SUM - ONE) .GT. TOL ) THEN WRITE (NPRT,*) 'SUPPLIED SHAPE FUNCTIONS INCORRECT' WRITE (NPRT,*) 'SUM ', SUM CALL RPRINT (H,1,N,1) WRITE (NPRT,*) 'END OF WARNING FROM SCHECK' ENDIF RETURN END SUBROUTINE SET (NNPFIX,NNPFLO,NLPFIX,NLPFLO,MISCFX, 1 MISCFL,IPTEST,LPTEST,NHOMO,LHOMO,M,N,NE, 2 RATIO,MAXTYP,NELFRE,NDFREE,NFLUX,NG,LBN) C * * * * * * * * * * * * * * * * * * * * * * * * * C SET DIMENSIONS OF PROPERTIES ARRAYS C * * * * * * * * * * * * * * * * * * * * * * * * * C LPTEST > 0, ELEMENT PROPERTIES ARE DEFINED C IPTEST > 0, SOME PROPERTIES ARE DEFINED C NLPFIX = NUMBER OF FIXED PT ELEMENT PROP C NLPFLO = NUMBER OF FLOATING PT ELEMENT PROP C NNPFIX = NUMBER OF FIXED PT NUMBER PROP C NNPFLO = NUMBER OF FLOATING PT NUMBER PROP C MISCFL = NUMBER OF MISC FLOATING PT SYSTEM PROP C MISCFX = NUMBER OF MISC FIXED PT SYSTEM PROP C LHOMO = 1, IF ELEMENT PROPERTIES ARE HOMOGENEOUS C NHOMO = 1, IF NODAL PROPERTIES ARE HOMOGENEOUS C MAXTYP = MAX ALLOWED CONSTRAINT TYPE C RATIO = CONSTANT FOR ITER CONTROL, SEE MODEL RATIO = 1.0 MAXTYP = 5 NELFRE = N*NG NDFREE = M*NG NFLUX = LBN*NG IF ( NFLUX .LT. 1 ) NFLUX = 1 IPTEST = NNPFIX + NNPFLO + NLPFIX + NLPFLO 1 + MISCFX + MISCFL LPTEST = NLPFIX + NLPFLO RETURN END SUBROUTINE SHP16QS (R,S,H) C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C SHAPE FUNCTIONS FOR SERENDIPITY QUAD WITH 16 NODES C A BI-4TH ORDER ELEMENT C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * PARAMETER ( PT667 = 0.66666666666667 ) DIMENSION H(16) C R,S = LOCAL COORDS OF PT 4--15--11---7---3 C H = ELEM SHAPE FUNCTIONS I I C 8 S 14 C LNODE = ELEM INCIDENCES LIST I . I C ELEMENT SKETCH TO RIGHT 12 +..R 10 C I I C 1@(-1,-1) 3@(+1,+1) 16 6 C I I C 1---5---9--13---2 RR = R*R SS = S*S RS = R*S RP = 1. + R RM = 1. - R SP = 1. + S SM = 1. - S H(1) = RM*SM*(-R*(4. * RR - 1.) - S*(4.*SS - 1.) - 3.)/12. H(5) = -PT667*R*SM*RM*RP * (1. - 2.*R) H(9) = 0.5*RM*RP * (1. - 4.*RR) * SM H(13) = PT667*R*SM*RM*RP * (1. + 2.*R) H(2) = RP*SM*(R*(4.*RR - 1.) - S*(4.*SS - 1.) - 3.)/12. H(6) = -PT667*S*RP*SM*SP * (1. - 2.*S) H(10) = 0.5*SM*SP*(1. - 4.*SS) * RP H(14) = PT667*S*RP*SM*SP * (1. + 2.*S) H(3) = RP*SP*(R*(4.*RR - 1.) + S*(4.*SS - 1.) - 3.)/12. H(7) = PT667*R*SP*RM*RP * (1. + 2.*R) H(11) = 0.5*RM*RP * (1. - 4.*RR) * SP H(15) = -PT667*R*SP*RM*RP * (1. - 2.*R) H(4) = RM*SP*(-R*(4.*RR - 1.) + S*(4.*SS - 1.) - 3.)/12. H(8) = PT667*S*SM*SP * (1. + 2.*S) * RM H(12) = 0.5*SM*SP * (1. - 4.*SS) * RM H(16) = -PT667*S*RM*SM*SP * (1. - 2.*S) RETURN END SUBROUTINE SHP16R (R,S,A,B,H) C * * * * * * * * * * * * * * * * * * * * * * C WARNING, this code is not fully checked. No known bugs. C C1 RECTANGULAR ELEMENT IN UNIT COORDINATES C USING TENSOR PRODUCTS OF 1D BASIS C * * * * * * * * * * * * * * * * * * * * * * DIMENSION H(16), HR(4), HS(4) C DOF ARE W W,X W,Y W,XY AT EACH NODE (NG=4) C X // R, Y // S. S C A = PHYSICAL LENGTH IN X 4 -------- 3 C B = PHYSICAL LENGTH IN Y I I C R,S = LOCAL UNIT COORDS I I C 1@(0,0), 3@(1,1) 1 -------- 2 ->R C C Evaluate the 1D interpolations CALL SHPC1L (R,A,HR) CALL SHPC1L (S,B,HS) C Form tensor products H(1) = HR(1)*HS(1) H(2) = HR(2)*HS(1) H(3) = HR(1)*HS(2) H(4) = HR(2)*HS(2) H(5) = HR(3)*HS(1) H(6) = HR(4)*HS(1) H(7) = HR(3)*HS(2) H(8) = HR(4)*HS(2) H(9) = HR(3)*HS(3) H(10) = HR(4)*HS(3) H(11) = HR(3)*HS(4) H(12) = HR(4)*HS(4) H(13) = HR(1)*HS(3) H(14) = HR(2)*HS(3) H(15) = HR(1)*HS(4) H(16) = HR(2)*HS(4) RETURN END SUBROUTINE SHP17Q (R,S,H) C ****************************************************************** C SHAPE FUNCTIONS FOR A SERENDIPITY QUAD WITH 17 NODES C ****************************************************************** PARAMETER ( PT667 = 0.6666666666666667 ) DIMENSION H(17) C R,S = LOCAL COORDS OF PT 4--15--11---7---3 C H = ELEM SHAPE FUNCTIONS I I C 8 S 14 C LNODE = ELEM INCIDENCES LIST I I I C ELEMENT SKETCH TO RIGHT 12 17-R 10 C I I C 1@(-1,-1) 3@(+1,+1) 16 6 C 17@(0,0) I I C 1---5---9--13---2 RR = R*R SS = S*S RS = R*S RP = 1. + R RM = 1. - R SP = 1. + S SM = 1. - S H(1) = RM*SM*(-4.*R*(RR - 1.) - 4.*S*(SS - 1.) + 3.*RS)/12. H(5) = -PT667*R*SM*RM*RP*(1. - 2.*R) H(9) = 0.5*RM*RP*(-S - 4.*RR)*SM H(13) = PT667*R*SM*RM*RP*(1. + 2.*R) H(2) = RP*SM*(4.*R*(RR - 1.) - 4.*S*(SS - 1.) - 3.*RS)/12. H(6) = -PT667*S*RP*SM*SP*(1. - 2.*S) H(10) = 0.5*SM*SP*(R - 4.*SS)*RP H(14) = PT667*S*RP*SM*SP*(1. + 2.*S) H(3) = RP*SP*(4.*R*(RR - 1.) + 4.*S*(SS - 1.) + 3.*RS)/12. H(7) = PT667*R*SP*RM*RP*(1. + 2.*R) H(11) = 0.5*RM*RP*(S - 4.*RR)*SP H(15) = -PT667*R*SP*RM*RP*(1. - 2.*R) H(4) = RM*SP*(-4.*R*(RR - 1.) + 4.*S*(SS - 1.) - 3.*RS)/12. H(8) = PT667*S*SM*SP*(1. + 2.*S)*RM H(12) = 0.5*SM*SP*( -R - 4.*SS)*RM H(16) = -PT667*S*RM*SM*SP*(1. - 2.*S) H(17) = RM*RP*SM*SP RETURN END SUBROUTINE SHP208 (R, S, T, H, LNODE) C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C ELEMENT INTERPOLATION FUNCTIONS FOR AN 8 TO 20 NODE HEXAHEDRON C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8 (A-H,O-Z) DIMENSION H(20), LNODE(20), I1(20), I2(20) DATA I1 /8*0, 1, 2, 3, 4, 5, 6, 7, 8, 1, 2, 3, 4/ DATA I2 /8*0, 2, 3, 4, 1, 6, 7, 8, 5, 5, 6, 7, 8/ C R,S,T = LOCAL COORDINATES OF THE POINT -1 LE (R,S,T) LE +1 C H = ELEMENT INTERPOLATION FUNCTIONS, H(I) = 0 IF LNODE(I) = 0 C LNODE = ARRAY OF ELEMENT INCIDENCES, C IF LNODE(I)=0 THEN LOCAL NODE I IS NOT CONSIDERED IN ANALYSIS C I1, I2 = CORNER NODES OF TWELVE EDGES C C A SKETCH OF THE LOCAL NODES... T 3 *----*----* 2 C : /. 10 /: C FACES DEFINED BY R.H.R. ABOUT : / . / : C THE POSITIVE LOCAL AXES *---S / *19 / *18 C +R,(8,5,1,4,16,17,12,20) / 11 * . 9* : C -R,(7,6,2,3,14,18,10,19) / / . / : C +S,(6,2,1,5,18,9,17,13) R / 7*.../*....* 6 C -S,(7,3,4,8,19,11,20,15) / 12 . / 14 / C +T,(3,4,1,2,11,12,9,10) 4 *----*----* 1 / C -T,(7,8,5,6,15,16,13,14) : . : / C AND R FACE : *15 : * 13 C 7 V 7 V 20 * . 17* / C 7 V 7 V : . : / C T <<< S COORD2 <<<< COORD1 :. 16 :/ C ARE THE FACE COORD. PERMUTATIONS 8 *----*----* 5 C RP = 0.5*(1. + R) SP = 0.5*(1. + S) TP = 0.5*(1. + T) RM = 0.5*(1. - R) SM = 0.5*(1. - S) TM = 0.5*(1. - T) RZ = 1. - R*R SZ = 1. - S*S TZ = 1. - T*T H( 1) = TP*SP*RP H( 2) = TP*SP*RM H( 3) = TP*SM*RM H( 4) = TP*SM*RP H( 5) = TM*SP*RP H( 6) = TM*SP*RM H( 7) = TM*SM*RM H( 8) = TM*SM*RP C QUADRATIC EDGE BUBBLES H( 9) = TP*SP*RZ*0.5 H(10) = TP*SZ*RM*0.5 H(11) = TP*SM*RZ*0.5 H(12) = TP*SZ*RP*0.5 H(13) = TM*SP*RZ*0.5 H(14) = TM*SZ*RM*0.5 H(15) = TM*SM*RZ*0.5 H(16) = TM*SZ*RP*0.5 H(17) = TZ*SP*RP*0.5 H(18) = TZ*SP*RM*0.5 H(19) = TZ*SM*RM*0.5 H(20) = TZ*SM*RP*0.5 C LOOP OVER TWELVE ELEMENT EDGES DO 20 K = 9,20 IF ( LNODE(K) .EQ. 0 ) THEN C SET UNUSED EDGE BUBBLE TO ZERO H(K) = 0.0 ELSE C ENRICH THE TWO CORNERS ON THE EDGE HK = H(K) K1 = I1(K) K2 = I2(K) H(K1) = H(K1) - HK H(K2) = H(K2) - HK H(K) = HK + HK ENDIF 20 CONTINUE RETURN END SUBROUTINE SHP2L (R,H) C * * * * * * * * * * * * * * * * * * * * * * * * * C SHAPE FUNCTIONS OF A 2 NODE LINE ELEMENT C * * * * * * * * * * * * * * * * * * * * * * * * * DIMENSION H(2) C R IS UNIT COORD. R=-1 1------------2 R=1 H(1) = 0.5*(1.0-R) H(2) = 0.5*(1.0+R) RETURN END SUBROUTINE SHP3L (X, H) C * * * * * * * * * * * * * * * * * * * * * * * * * * C CALCULATE SHAPE FUNCTIONS OF A 3 NODE LINE ELEMENT C IN NATURAL COORDINATES C * * * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8 (A-H,O-Z) DIMENSION H(3) C H = ELEMENT SHAPE FUNCTIONS C X = LOCAL COORDINATE OF POINT, -1 TO +1 C LOCAL NODE COORD. ARE -1,0,+1. 1-----2-----3 H(1) = 0.5*(X*X - X) H(2) = 1. - X*X H(3) = 0.5*(X*X + X) RETURN END SUBROUTINE SHP3T (S, T, H) C * * * * * * * * * * * * * * * * * * * * * * * * * * C SHAPE FUNCTIONS FOR A THREE NODE UNIT TRIANGLE C * * * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8 (A-H,O-Z) DIMENSION H(3) C S,T = LOCAL COORDINATES OF THE POINT 3 T C H = SHAPE FUNCTIONS . . . C NODAL COORDS 1-(0,0) 2-(1,0) 3-(0,1) 1..2 0..S H(1) = 1. - S - T H(2) = S H(3) = T RETURN END SUBROUTINE SHP412 (R, S, H, LNODE) C * * * * * * * * * * * * * * * * * * * * * * * * * * C SHAPE FUNCTIONS OF 4 TO 12 NODE QUADRILATERAL C * * * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8 (A-H,O-Z) DIMENSION H(12), LNODE(12), IP(4), JP(4), NEXT(4) DATA IP,JP,NEXT /1,0,-1,0, 0,1,0,-1, 2,3,4,1/ C R,S = LOCAL COORDS OF PT 4--11---7---3 C H = ELEM SHAPE FUNCTIONS : S : C LNODE = ELEM INCIDENCES LIST 8 : 10 C ELEMENT SKETCH TO RIGHT : *..R : C LOCAL COORD OF NODES: 12 6 C 1-(-1,-1) 3-(+1,+1) : : C SIDES OF ORDER 1, 2, OR 3 1---5---9---2 C--> GENERATE FOUR NODE BILINEAR QUADRILATERAL CALL SHP4Q (R,S,H) C--> LOOP OVER SIDES DO 10 I = 1,4 H(I+4) = 0. H(I+8) = 0. C IS SIDE HIGHER THAN LINEAR ? IF ( LNODE(I+4) .GT. 0 ) THEN K = NEXT(I) C FIND PT RELATIVE TO SIDE (CYCLIC COORDINATES) P = R*IP(I) + S*JP(I) Q =-R*JP(I) + S*IP(I) TEMP = (1. - Q)*0.5 C--> IS SIDE QUADRATIC OR CUBIC ? IF ( LNODE(I+8) .GT. 0 ) THEN C CUBIC H(I+8) = TEMP*(1. - 3.*P - P*P + 3.*P*P*P)*9./16. H(I+4) = TEMP*(1. + 3.*P - P*P - 3.*P*P*P)*9./16. C CORRECT CORNER POINTS FOR CUBIC H(I) = H(I) - H(I+4)*2./3. - H(I+8)/3. H(K) = H(K) - H(I+8)*2./3. - H(I+4)/3. ELSE C QUADRATIC H(I+4) = TEMP*(1. - P*P) C CORRECT CORNER POINTS FOR QUADRATIC H(I) = H(I) - H(I+4)*0.5 H(K) = H(K) - H(I+4)*0.5 ENDIF ENDIF 10 CONTINUE RETURN END SUBROUTINE SHP4Q (R, S, H) C * * * * * * * * * * * * * * * * * * * * * * * * * * C SHAPE FUNCTIONS OF A 4 NODE ISOPARAMETRIC QUAD C IN NATURAL COORDINATES C * * * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8 (A-H,O-Z) DIMENSION H(4) C (R,S) = A POINT IN THE NATURAL COORDS 4--3 C H = LOCAL INTERPOLATION FUNCTIONS I I C H(I) = 0.25*(1+R*R(I))*(1+S*S(I)) I I C R(I) = LOCAL R-COORDINATE OF NODE I 1--2 C LOCAL COORDS, 1=(-1,-1) 3=(+1,+1) RP = 1. + R RM = 1. - R SP = 1. + S SM = 1. - S H(1) = 0.25*RM*SM H(2) = 0.25*RP*SM H(3) = 0.25*RP*SP H(4) = 0.25*RM*SP RETURN END SUBROUTINE SHP6T (S,T,H) C * * * * * * * * * * * * * * * * * * * * * * * * * * C LOCAL SHAPE FUNCTIONS FOR A SIX NODE UNIT TRIANGLE C * * * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8 (A-H,O-Z) DIMENSION H(6) C S,T = LOCAL COORDINATES 3 C OF A POINT IN THE UNIT TRIANGLE C H = SIX SHAPE FUNCTIONS FOR A QUADRATIC T 6 5 C ELEMENT WITH SIX NODES : C THE NODAL ORDER IS SHOWN TO THE RIGHT .-S 1 4 2 C NODAL COORDS : 1-(0,0) 2-(1,0) 3-(0,1) C 4-(0.5,0) 5-(0.5,0.5) 6-(0,0.5) H(1) = 1. - 3.*S - 3.*T + 2.*S*S + 4.*S*T + 2.*T*T H(2) = 2.*S*S - S H(3) = 2.*T*T - T H(4) = 4.*(S - S*S - S*T) H(5) = 4.*S*T H(6) = 4.*(T - S*T - T*T) RETURN END SUBROUTINE SHP8H (R,S,T,H) C * * * * * * * * * * * * * * * * * * * * * * * * * * C SHAPE FUNCTIONS OF 8 NODE ISOPARAMETRIC HEXAHEDRON C * * * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8 (A-H,O-Z) DIMENSION H(8) C R,S,T = LOCAL COORDS OF PT | T C H = ELEM SHAPE FUNCTIONS 6/--/5 C NODES ORDERED BY RHR / / | C ABOUT THE R-AXIS 2/--/1 /|--S C LOCAL COORD:1=(1,1,1) | : / 8 C 4=(1,1,-1) 7=(-1,-1,-1) R 3|--|/ 4 RP = 1. + R RM = 1. - R SP = 1. + S SM = 1. - S TP = 1. + T TM = 1. - T H(1) = 0.125*RP*SP*TP H(2) = 0.125*RP*SM*TP H(3) = 0.125*RP*SM*TM H(4) = 0.125*RP*SP*TM H(5) = 0.125*RM*SP*TP H(6) = 0.125*RM*SM*TP H(7) = 0.125*RM*SM*TM H(8) = 0.125*RM*SP*TM RETURN END SUBROUTINE SHP8Q (S,T,H) C * * * * * * * * * * * * * * * * * * * * * * * * * * C SHAPE FUNCTIONS OF 8 NODE ISOPARAMETRIC QUADRILATERAL C * * * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8 (A-H,O-Z) DIMENSION H(8) C NODAL ORDER SHOWN TO RIGHT. 4 - 7 - 3 C S,T = LOCAL COORDINATES OF POINT : T : C H = SHAPE FUNCTION ARRAY 8 *S 6 C NODE 1 AT (-1,-1) : : C NODE 3 AT (1,1) 1 - 5 - 2 SP = 1. + S SM = 1. - S TP = 1. + T TM = 1. - T H(1) = 0.25*SM*TM*( SM + TM - 3. ) H(2) = 0.25*SP*TM*( SP + TM - 3. ) H(3) = 0.25*SP*TP*( SP + TP - 3. ) H(4) = 0.25*SM*TP*( SM + TP - 3. ) H(5) = 0.5*TM*( 1. - S*S ) H(6) = 0.5*SP*( 1. - T*T ) H(7) = 0.5*TP*( 1. - S*S ) H(8) = 0.5*SM*( 1. - T*T ) RETURN END SUBROUTINE SHP9Q ( R, S, H ) C * * * * * * * * * * * * * * * * * * * * * * * * C SHAPE FUNCTIONS FOR 9-NODED QUAD C * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8 (A-H,O-Z) DIMENSION H(9) C R,S = LOCAL COORDS OF PT 4-----7-----3 C H = ELEM SHAPE FUNCTIONS I S I C LNODE = ELEM INCIDENCES LIST I . I C ELEMENT SKETCH TO RIGHT 8 9..R 6 C 1@(-1,-1) 3@(+1,+1) I I C I I C 1-----5-----2 RM = R - 1.D0 SM = S - 1.D0 RP = R + 1.D0 SP = S + 1.D0 H(1) = 0.25D0 *S * SM * R * RM H(2) = 0.25D0 * S * SM* R * RP H(3) = 0.25D0 * S* SP * R * RP H(4) = 0.25D0 * S * SP * R * RM H(5) = -0.5D0 * S * SM * RP * RM H(6) = -0.5D0 * SP *SM * R* RP H(7) = -0.5D0 * S * SP * RP * RM H(8) = -0.5D0 * SP * SM* R * RM H(9) = SP * SM * RP * RM RETURN END SUBROUTINE SHPC0L (R,H) C * * * * * * * * * * * * * * * * * * * * * C C0 LINE ELEM IN UNIT COORDINATES C * * * * * * * * * * * * * * * * * * * * * DIMENSION H(2) C H = SHAPE FUNCTIONS (R=0) 1----2 (R=1) ->R C DOF ARE FUNCTION VALUES AT EACH NODE H(1) = 1. - R H(2) = R RETURN END SUBROUTINE SHPC1L (R,A,H) C * * * * * * * * * * * * * * * * * * * * * * * * * * * * C SHAPE FUNCTIONS FOR CUBIC HERMITE IN UNIT COORDINATES C ( A C1 ELEMENT ) C * * * * * * * * * * * * * * * * * * * * * * * * * * * * DIMENSION H(4) C A = PHYSICAL LENGTH OF ELEMENT 1----------2 ---> R C R = LOCAL COORDINATE OF POINT R=0 R=1 C H = SHAPE FUNCTIONS ARRAY C DOF ARE FUNCTION AND SLOPE, WRT X, AT EACH NODE (NG=2) C D()/DX = D()/DR DR/DX = 1/A * D()/DR H(1) = 1.0 - 3.0*R*R + 2.0*R*R*R H(2) = (R - 2.0*R*R + R*R*R)*A H(3) = 3.0*R*R - 2.0*R*R*R H(4) = (R*R*R - R*R)*A RETURN END SUBROUTINE SHPC2L (R,A,H) C * * * * * * * * * * * * * * * * * * * * * * * * * * * C SHAPE FUNCTIONS FOR FIFTH ORDER HERMITE LINE ELEMENT C ( A C2 ELEMENT IN UNIT COORDINATES) C * * * * * * * * * * * * * * * * * * * * * * * * * * * DIMENSION H(6) C A = PHYSICAL LENGTH OF ELEMENT 1----------2 -> R C R = LOCAL COORDINATE OF POINT R=0 R=1 C H = SHAPE FUNCTIONS ARRAY C DOF ARE VALUE, SLOPE, CURVATURE AT EACH END (WRT X) C D()/DX = D()/DR DR/DX = 1/A * D()/DR R3 = R*R*R H(1) = 1.- 10.*R3 + 15.*R3*R - 6.*R3*R*R H(2) = (R - 6.*R3 + 8.*R3*R - 3.*R3*R*R)*A H(3) = (R*R - 3.*R3 + 3.*R3*R - R3*R*R)*A*A/2. H(4) = 10.*R3 - 15.*R3*R + 6.*R3*R*R H(5) = (7.*R3*R - 3.*R3*R*R - 4.*R3)*A H(6) = (R3 - 2.*R3*R + R3*R*R)*A*A/2. RETURN END SUBROUTINE SHPC3L (R,A,H) C * * * * * * * * * * * * * * * * * * * * * * * * * * * * C SHAPE FUNCTIONS FOR SEVENTH ORDER HERMITE LINE ELEMENT C ( A C3 ELEMENT IN UNIT COORDINATES) C * * * * * * * * * * * * * * * * * * * * * * * * * * * * DIMENSION H(8) C A = PHYSICAL LENGTH OF ELEMENT 1----------2 -> R C R = LOCAL COORDINATE OF POINT R=0 R=1 C H = SHAPE FUNCTIONS ARRAY C DOF ARE VALUE, SLOPE, 2ND, 3RD DERIV AT EACH END (WRT X) C D()/DX = D()/DR DR/DX = 1/A * D()/DR R2 = R*R R4 = R2*R2 H(1) = 1.- 35.*R4 + 84.*R*R4 - 70.*R4*R2 + 20.*R4*R2*R H(2) = (R - 20.*R4 + 45.*R*R4 -36.*R4*R2 + 10.*R4*R2*R)*A H(3) = (R2 - 10.*R4 + 20.*R*R4 - 15.*R4*R2 + 4.*R4*R2*R)*A*A/2. H(4) = (R*R2 - 4.*R4 + 6.*R*R4 - 4.*R4*R2 + R4*R2*R)*A*A*A/6. H(5) = 35.*R4 - 84.*R*R4 + 70.*R4*R2 - 20.*R4*R2*R H(6) = (10.*R4*R2*R - 34.*R4*R2 + 39.*R*R4 - 15.*R4)*A H(7) = (5.*R4 - 14.*R*R4 + 13.*R4*R2 -4.*R4*R2*R)*A*A/2. H(8) = (R4*R2*R - 3.*R4*R2 + 3.*R*R4 - R4)*A*A*A/6. RETURN END SUBROUTINE SHPCU (B, A, H) C * * * * * * * * * * * * * * * * * * * * * * * * * * C SHAPE FUNCTIONS FOR A CUBIC HERMITE, UNIT COORD C * * * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8 (A-H,O-Z) DIMENSION H(4) C A = LENGTH OF ELEMENT 1----------2 -> B C B = COORDINATE OF POINT B=0 B=1 C H = SHAPE FUNCTIONS ARRAY H(1) = 1.-3.*B*B + 2.*B*B*B H(2) = (B - 2.*B*B + B*B*B)*A H(3) = 3.*B*B - 2.*B*B*B H(4) = (B*B*B - B*B)*A RETURN END SUBROUTINE SHPHQL (NODEDG, LOCATE, NEDGE, LEDGES, NSPACE, & RST, VALUE) C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C SHAPE FUNCTIONS FOR GENERAL SERENDIPITY C LINE, QUAD, OR OR HEXAHEDRON WITH AN C ARBITRARY NUMBER OF NODES ON EACH EDGE C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8 (A-H,O-Z) PARAMETER ( MAXDEG = 20 ) DIMENSION RST(3), BLKCRD(3,8), POLI2(3), CDRFN(3), & FARSID(3), CRDEDG(3,MAXDEG+1), & NODEDG(12), NEATC(3,8), NODEOP(2,12), & NODATC(3), LOCAL(12) DATA BLKCRD &/ -1.,-1.,-1., 1.,-1.,-1., 1.,1.,-1., -1.,1.,-1., & -1.,-1., 1., 1.,-1., 1., 1.,1., 1., -1.,1., 1./ DATA NEATC / 1,4,9, 1,2,10, 3,2,11, 3,4,12, & 5,8,9, 5,6,10, 7,6,11, 7,8,12 / DATA NODEOP / 7,8, 8,5, 5,6, 6,7, & 3,4, 4,1, 1,2, 2,3, & 3,7, 4,8, 1,5, 2,6 / DATA LOCAL / -1, -2, 1, 2, -1, -2, 1, 2, -3, -3, -3, -3 / C BLKCRD = BLOCK CORNER LOCAL COORDINATES C CRDEDG = LOCAL COORDINATES OF SIDE NODES JOINING CORNER C FARSID = FAR SIDE LOCAL COORDINATE C LEDGES = NUMBER OF ELEMENT EDGES, 1, 4, OR 12 C LOCAL = LOCAL COORDINATE PARALLEL TO EACH EDGE C LOCATE = POSITION NUMBER ON EDGE, 0 IF CORNER C MAXDEG = MAXIMUM PLOYNOMIAL DEGREE ON ANY SIDE C NEATC = THE 1, 2, OR 3 EDGES AT A CORNER C NEDGE = EDGE NUMBER OR CORNER NUMBER OF THE NODE COMPUTED C NODATC = NUMBER OF SIDE NODES JOINING A CORNER C NODEDG = NUMBER ON NODES ON 1,4, OR 12 EDGES C NODEOP = 2 DIAGONALLY OPPOSITE NODES FOR EACH EDGE C NSPACE = NUMBER OF SPATIAL DIMENSIONS C RST = LOCAL COORDINATES FOR EVALUATION C VALUE = SHAPE FUNCTION VALUE (RETURNED) C C VALUE = A(R,S,T)*( P1(R) + P2(S) + P3(T) + CONSTANT ) C C REF: G. ZAVARISE, ET AL, "AN ALGORITHM FOR GENERATION OF SHAPE C FUNCTIONS IN SERENDIPITY ELEMENTS", ENG COMP,8,19-31,1991 C C T: S C8 *---E7----* C7 T: S 8---15----7 C : / /. /: : / /. /: C :/ / . / : :/ / 22 / : C *---R / E12 / E11 *---R / . / 20 C E8 . E6 : 16 21 / : C / . / : / . / : C / C4*.../.E3..* C3 / 4.13/.12..3 C / . / / / . / / C C5 *--E5-----* C6 / 5---------6 / C : . : / : . : 11 C : E4 : E2 : 14 19 / C E9 . E10 / 17 . : 10 C : . : / : . 18 / C :. :/ :. :/ C C1 *---E1----* C2 1----9----2 C CORNER NODE & EDGE NUMBERS. 22 NODES: CORNERS, THEN BY EDGES. C CCW IF |T|=1, ELSE IN POSITIVE T. C === 3-D FORM === C C C4 *---E3----* C3 4----8----3 C : . : :S : : C : : : : : C E4 E2 : 9 : C : : *---R : : C : : : : C C1 *---E1----* C2 1--5-6-7--2 C CORNER NODE & EDGE NUMBERS. 9 NODES: CORNERS, THEN BY EDGE ORDER. C === 2-D FORM === C C C1 *---E1----* C2 1--2-3-4--5 C CORNER NODE & EDGE NUMBERS. 9 NODES NUMBERED BY EDGE ORDER. C === 1-D FORM === POLI1 = 1. IF ( LOCATE .EQ. 0 ) THEN C C SHAPE FUNCTION FOR CORNER NODES C DO 100 ICORD = 1,NSPACE POLI1 = POLI1*(RST(ICORD) + BLKCRD(ICORD,NEDGE)) & /(2*BLKCRD(ICORD,NEDGE)) 100 CONTINUE CPNUL = 1. POLI2(1) = 0. POLI2(2) = 0. POLI2(3) = 0. DO 200 ICORD = 1,NSPACE NSIDE = NEATC(ICORD,NEDGE) NODATC(ICORD) = NODEDG(NSIDE) - 2 IF ( NODATC(ICORD) .GT. 0 ) THEN IF ( NODATC(ICORD) .GT. MAXDEG ) STOP 'MAXDEG, SHPHQL' CPNUL = CPNUL - 1. POLI2(ICORD) = 1. FARSID(ICORD) = 2./(NODEDG(NSIDE) - 1) DO 300 INODE = 1,NODATC(ICORD) CRDEDG(ICORD,INODE) = -1. + FARSID(ICORD)*INODE POLI2(ICORD) = POLI2(ICORD)*(RST(ICORD) & - CRDEDG(ICORD,INODE))/(BLKCRD(ICORD,NEDGE) & - CRDEDG(ICORD,INODE)) 300 CONTINUE ENDIF 200 CONTINUE VALUE = POLI1*(POLI2(1) + POLI2(2) + POLI2(3) + CPNUL) ELSE C C SHAPE FUNCTION FOR EDGE NODES C NOPV1 = NODEOP(1,NEDGE) NOPV2 = NODEOP(2,NEDGE) ISRFN = ABS(LOCAL(NEDGE)) FARSID(1) = 2./(NODEDG(NEDGE) - 1) CDRFN(1) = -BLKCRD(1,NOPV1) CDRFN(2) = -BLKCRD(2,NOPV1) CDRFN(3) = -BLKCRD(3,NOPV1) CDRFN(ISRFN) = (1. - FARSID(1)*LOCATE)*LOCAL(NEDGE)/ISRFN DO 400 ICORD = 1,NSPACE POLI1 = POLI1*(RST(ICORD) - BLKCRD(ICORD,NOPV1)) & /(CDRFN(ICORD) - BLKCRD(ICORD,NOPV1)) 400 CONTINUE PLAN2 = (RST(ISRFN) - BLKCRD(ISRFN,NOPV2)) & /(CDRFN(ISRFN) - BLKCRD(ISRFN,NOPV2)) POLI3 = 1. NODATC(1) = NODEDG(NEDGE) - 2 IF ( NODATC(1) .GT. 0 ) THEN IF ( NODATC(1) .GT. MAXDEG ) STOP 'MAXDEG, SHPHQL' DO 500 INODE = 1,NODATC(1) CRDEDG(1,INODE) = -1. + FARSID(1)*INODE IF ( ABS(CRDEDG(1,INODE) - CDRFN(ISRFN)) .GT. 0.0001) & THEN POLI3 = POLI3*(RST(ISRFN) - CRDEDG(1,INODE)) & /(CDRFN(ISRFN) - CRDEDG(1,INODE)) ENDIF 500 CONTINUE ENDIF VALUE = POLI1*PLAN2*POLI3 ENDIF RETURN END SUBROUTINE SHPLEG (N, X, P, DPDX) C * * * * * * * * * * * * * * * * * * * * * * * * * * C RECURSION RELATIONS FOR LEGENDRE POLYNOMIALS C TO DEGREE N, AND THEIR LOCAL DERIVATIVES ON 0,1 C * * * * * * * * * * * * * * * * * * * * * * * * * * DIMENSION P(0:N), DPDX(0:N) C RECOMMEND THAT X BE DOUBLE PRECISION P(0) = 1.D0 DPDX(0) = 0.D0 IF ( N .LT. 1 ) RETURN DPDX(1) = 1.D0 P(1) = X IF ( N .GT. 1 ) THEN DO 10 J = 2, N P(J) = ( (J + J - 1)*X*P(J-1) - (J - 1)*P(J-2) )/J DPDX(J) = ( (J + J - 1)*X*DPDX(J-1) - J*DPDX(J-2))/(J-1) 10 CONTINUE ENDIF RETURN END SUBROUTINE SINGL2 (P,H,DH,N,NSPACE,NS) C * * * * * * * * * * * * * * * * * * * * * * * * * * C CONVERT STANDARD C^0 FUNCTIONS TO SINGULAR FUNCTIONS C WITH DERIV SINGULARITIES AT NODE NS OF O(R**(-P)) C * * * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8 (A-H,O-Z) DIMENSION H(N), DH(NSPACE,N) C H=SHAPE FUNCTION ARRAY, DH=LOCAL DERIVATIVES OF H C N=NO OF SHAPE FUNCTIONS, NSPACE=DIMENSION OF SPACE C NS=SINGULAR NODE NUMBER, 1.LE.NS.LE.N C REQUIRES SUM OF H(I) = 1, & CONST JACOBIAN IF ( P.EQ.0.0 ) RETURN W = 1.0 - H(NS) R = W**P DO 20 I = 1,NSPACE DO 10 J = 1,N IF ( J.EQ.NS ) GO TO 10 DH(I,J) = DH(I,J)/R + P*DH(I,NS)*H(J)/R/W 10 CONTINUE DH(I,NS) = (1.0 - P)*DH(I,NS)/R 20 CONTINUE DO 30 J = 1,N IF ( J.EQ.NS ) GO TO 30 H(J) = H(J)/R 30 CONTINUE H(NS) = 1.0 - W/R RETURN END SUBROUTINE SINGLR (P, H, DH, N, NSPACE) C * * * * * * * * * * * * * * * * * * * * * * * * * * C CONVERT STANDARD C^0 FUNCTIONS TO SINGULAR FUNCTIONS C WITH DERIV SINGULARITIES AT NODE 1 OF O(R**(-P)) C * * * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8 (A-H,O-Z) DIMENSION H(N), DH(NSPACE,N) C H = SHAPE FUNCTION ARRAY (STANDARD) C DH = LOCAL DERIVATIVES OF H (STANDARD) C N = NUMBER OF SHAPE FUNCTIONS C NSPACE = DIMENSION OF SPACE C REQUIRES SUM OF H(I) = 1, & CONST JACOBIAN IF ( P .EQ. 0.0 ) RETURN W = 1.0 - H(1) R = W**P DO 20 I = 1,NSPACE DO 10 J = 2,N 10 DH(I,J) = DH(I,J)/R + P*DH(I,1)*H(J)/R/W DH(I,1) = (1.0 - P)*DH(I,1)/R 20 CONTINUE DO 30 J = 2,N 30 H(J) = H(J)/R H(1) = 1.0 - W/R RETURN END SUBROUTINE SIZEI (LOC,NEXTI,IN,IPT) C * * * * * * * * * * * * * * * * * * * * * * * * * * * C LIST NAMES AND SIZES OF INTEGER SUB-ARRAYS C * * * * * * * * * * * * * * * * * * * * * * * * * * * CHARACTER*8 IN DIMENSION IPT(1), IN(1) C C IN = Names of sub-arrays in I array C IPT = pointer array for sub-arrays in I C LOC = Array location. If < 1 list all. C NEXTI = Next free sub-array in I C K1 = 1 K2 = NEXTI - 1 IF ( LOC .GE. 1 ) THEN K1 = LOC K2 = LOC ENDIF WRITE (6,100) 100 FORMAT ( /,' INTEGER SUB-ARRAY DATA:', /, 1 ' NUMBER NAME BEGINNING SIZE') DO 10 K = K1, K2 ISIZE = IPT(K+1) - IPT(K) 10 WRITE (6,200) K, IN(K), IPT(K), ISIZE 200 FORMAT ( I7, 2X, A8, I10, I10 ) RETURN END SUBROUTINE SIZER (LOC,NEXTR,RN,JPT) C * * * * * * * * * * * * * * * * * * * * * * * * * * * C LIST NAMES AND SIZES OF REAL SUB-ARRAYS C * * * * * * * * * * * * * * * * * * * * * * * * * * * CHARACTER*8 RN DIMENSION JPT(1), RN(1) C C JPT = pointer array for sub-arrays in R C LOC = Array location. If < 1 list all. C NEXTR = Next free sub-array in R C RN = Names of sub-arrays in R array C K1 = 1 K2 = NEXTR - 1 IF ( LOC .GE. 1 ) THEN K1 = LOC K2 = LOC ENDIF WRITE (6,100) 100 FORMAT ( /,' REAL SUB-ARRAY DATA:', /, 1 ' NUMBER NAME BEGINNING SIZE') DO 10 K = K1, K2 ISIZE = JPT(K+1) - JPT(K) 10 WRITE (6,200) K, RN(K), JPT(K), ISIZE 200 FORMAT ( I7, 2X, A8, I10, I10 ) RETURN END SUBROUTINE SKYDIA (NDFREE, IDOFHI, IDIAG) C * * * * * * * * * * * * * * * * * * * * * * * * * C USE COLUMN HEIGHTS TO FIND DIAGONAL COEFFICIENTS C FOR SYMMETRIC SKYLINE STORAGE MODE C * * * * * * * * * * * * * * * * * * * * * * * * * C ASSUMING SYMMETRIC COLS STORED FROM TOP DOWN DIMENSION IDOFHI(NDFREE), IDIAG(NDFREE) C NDFREE = TOTAL NO OF SYSTEM EQUATIONS C IDOFHI(I) = COL HEIGHT OF EQ I, WITH DIAG C IDIAG(I) = LOCATION OF DIAG OF I-TH EQ NUMBER C COEFF IN UPPER TRIANGLE C TOTAL NUMBER OF SQ MATRIX TERMS = IDIAG(NDFREE) IPOINT = 0 DO 10 I = 1, NDFREE IPOINT = IPOINT + IDOFHI(I) 10 IDIAG(I) = IPOINT RETURN END SUBROUTINE SKYEBC (NDFREE, NOCOEF, N, VALUE, S, C, IDIAG) C * * * * * * * * * * * * * * * * * * * * * * * * * * * C APPLY TYPE 1 MODIFICATION TO SYMMERTIC SKYLINE EQS C S*D = C, D(N) = VALUE C * * * * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8 (A-H,O-Z) DIMENSION S(NOCOEF), C(NDFREE), IDIAG(NDFREE) C NDFREE = DFREE NUMBER OF EQUATIONS C NOCOEF = NUMBER OF NON-ZERO COEFFICIENTS IN S C N = DOF NUMBER OF CONSTRAINED PARAMETER C VALUE = GIVEN VALUE OF DOF NUMBER N C S = SYSTEM SQUARE MATRIX IN SKYLINE STORAGE MODE C C = FULL COLUMN MATRIX C IDIAG = POINTER TO DIAGONAL COEFFICIENT IN S C SUBTRACT COLUMN*VALUE FROM RHS DO 10 I = 1, NDFREE C FIND S(I,N) IN S VECTOR ID = MAX0(I,N) INV = IDIAG(ID) - IABS(I-N) ITOP = 1 IF ( ID .GT. 1 ) ITOP = IDIAG(ID - 1) + 1 C IS IT OUTSIDE SKYLINE AND THUS ZERO? IF ( INV .GE. ITOP ) THEN C(I) = C(I) - VALUE*S(INV) S(INV) = 0.0 ENDIF 10 CONTINUE C RESET THE EQUATION ROW S(IDIAG(N)) = 1.0 C(N) = VALUE RETURN END SUBROUTINE SKYFAC (NDFREE,NOCOEF,IDIAG,S) C * * * * * * * * * * * * * * * * * * * * * * * * * * C L*D*LT FACTORIZATION OF SYSTEM SQUARE MATRIX S C STORED IN SYMMETRIC SKYLINE VECTOR MODE C * * * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8 (A-H,O-Z) DIMENSION S(NOCOEF), IDIAG(NDFREE) C NDFREE = TOTAL NUMBER OF SYSTEM DOF C NOCOEF = IDIAG(NDFREE) = NO OF COEFFS IN S C IDIAG(I) = LOCATION OF DIAGONAL OF EQ I C S = SYSTEM SQUARE MATRIX ZERO = 0.0 if ( zero .eq. zero ) stop 'fatal logic for height=1' C FACTOR OFF DIAGONAL TERMS DO 300 J = 2,NDFREE JOFF = IDIAG(J) - IDIAG(J-1) - 1 JTOP = J - JOFF ISTART = JTOP + 1 ISTOP = J - 1 JD = IDIAG(ISTOP) - JTOP + 1 IF ( ISTART.GT.ISTOP ) GO TO 110 DO 100 I = ISTART,ISTOP IOFF = IDIAG(I) - IDIAG(I-1) - 1 ITOP = I - IOFF NUM = MAX0 (ITOP,JTOP) NEND = I - NUM IJV = JD + I IL = IDIAG(I-1) + NUM - ITOP + 1 JG = JD + NUM 100 S(IJV) = S(IJV) - DOT(NEND,S(IL),S(JG)) C FACTOR DIAGONAL 110 ISTART = JTOP IF ( ISTART.GT.ISTOP ) GO TO 300 SUM = ZERO DO 200 I = ISTART,ISTOP IF ( S(IDIAG(I)).LE.ZERO ) GO TO 200 D = S(I+JD)/S(IDIAG(I)) SUM = SUM + S(I+JD)*D S(I+JD) = D 200 CONTINUE S(IDIAG(J)) = S(IDIAG(J)) - SUM 300 CONTINUE RETURN END SUBROUTINE SKYFUL (NDFREE, NOCOEF, S, IDIAG, FULL, C) C * * * * * * * * * * * * * * * * * * * * * * * * * * * C COPY SKYLINE S INTO SYMMETRIC FULL S AND PRINT WITH C C * * * * * * * * * * * * * * * * * * * * * * * * * * * DIMENSION S(NOCOEF), FULL(NDFREE,NDFREE), 1 C(NDFREE), IDIAG(NDFREE) DO 10 I = 1, NDFREE DO 20 J = I, NDFREE FULL(I, J) = 0.0 C FIND S(I, J) IN S VECTOR ID = MAX0(I, J) IJV = IDIAG(ID) - IABS(I-J) ITOP = 1 IF ( ID .GT. 1 ) ITOP = IDIAG(ID - 1) + 1 C IS IT OUTSIDE SKYLINE AND THUS ZERO? IF ( IJV .LT. ITOP ) GO TO 20 FULL(I, J) = S(IJV) FULL(J, I) = FULL(I, J) 20 CONTINUE 10 CONTINUE CALL RPRINT (FULL, NDFREE, NDFREE, 0) CALL RPRINT (C, NDFREE, 1, 0) RETURN END SUBROUTINE SKYHI (NDFREE, NE, N, NG, NELFRE, NODES, 1 LNODE, INDEX, LHIGH, IDOFHI) C * * * * * * * * * * * * * * * * * * * * * * * * * * C FIND COLUMN HEIGHTS OF SYSTEM EQUATIONS IN C SYMMETRIC SKYLINE STORAGE MODE C * * * * * * * * * * * * * * * * * * * * * * * * * * DIMENSION NODES(NE,N), LNODE(N), INDEX(NELFRE), 1 LHIGH(NELFRE), IDOFHI(NDFREE) C NDFREE = TOTAL NO OF SYSTEM DOF C NELFRE = NUMBER OF ELEMENT PARAMETERS (DOF) C NE = NUMBER OF ELEMENTS C N = NUMBER OF NODES PER ELEMENT C NG = NUMBER OF PARAMETERS PER NODE C NODES = NODAL INCIDENCES OF ALL ELEMENTS C LNODE = ELEMENT NODAL INCIDENCES C INDEX(I) = SYS DOF NUMBER OF ELEMENT DOF I C IDOFHI(I) = COL HEIGHT OF SYS DOF I C C ZERO HEIGHTS CALL ZEROI (NDFREE,IDOFHI) C LOOP OVER ELEMENTS DO 20 IE = 1, NE C EXTRACT NODES, FIND DOF NOS CALL LNODES (IE, NE, N, NODES, LNODE) CALL INDXEL (N, NELFRE, NG, LNODE, INDEX) C FIND ELEMENT COLUMN HEIGHTS CALL ELHIGH (NELFRE, INDEX, LHIGH) C COMPARE WITH CURRENT MAXIMUMS DO 10 J = 1, NELFRE NDX = INDEX(J) IF ( NDX .LT. 1 ) GO TO 10 IF ( IDOFHI(NDX) .LT. LHIGH(J) ) 1 IDOFHI(NDX) = LHIGH(J) 10 CONTINUE 20 CONTINUE RETURN END SUBROUTINE SKYLCE (NDFREE, S, C, NCD, NDX, A, NOCOEF, IDIAG) C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C APPLY LINEAR CONSTRAINTS TO SKYLINE SYMMETRIC EQUATIONS C S*D = C, WITH S IN VECTOR MODE AND C D(NDX(1))+A(1)*D(NDX(2))+...A(NCD-1)*D(NDX(NCD))=A(NCD) C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * PARAMETER ( ZERO = 0.0, ONE = 1.0 ) DIMENSION S(NOCOEF), C(NDFREE), A(NCD), IDIAG(NDFREE), 1 NDX(NCD) LOGICAL SKIP C NCOEFF = NUMBER OF TERMS FOR SQ MATRIX IN VECTOR MODE C NCD = TOTAL NUMBER OF DOF IN CONSTRAINT EQUATION C NDFREE = TOTAL NUMBER OF DEGREES OF FREEDOM C NDX(I) = SYS DOF NOS OF CONSTRAINT TERM I C NR = REDUNDANT DEGREE OF FREEDOM = NDX(1) C A(J) = NORMALIZED COEFF OF (J+1) TERM, A0 = 1.0 C C = SYSTEM COLUMN MATRIX : SII SIR SID : :DI: :CI: C S = SYSTEM SQUARE MATRIX : SRI SRR SRD : :DR:=:CR: C R-REDUNDANT, D-DEPENDENT : SDI SDR SDD : :DD: :CD: C E = A(NCD) NR = NDX(1) SRR = S(IDIAG(NR)) SRRP1 = SRR + ONE CR = C(NR) ESC = E*SRRP1 - CR C FIND TOP AND BOTTOM OF THE SKYLINE OF THE NR COLUMN CALL SKYTAL ( NDFREE, IDIAG, NR, ITOP, IBOT ) C FORM MODIFIED COLUMN MATRIX, CX = CX - E*SXR IF ( E .NE. ZERO ) THEN DO 10 I = ITOP, IBOT CALL SKYSUB ( NDFREE, IDIAG, I, NR, INRV ) IF ( INRV .NE. 0 ) C(I) = C(I) - E*S(INRV) 10 CONTINUE ENDIF C ADDITIONAL COLUMN CHANGES FOR CD AND CR IF ( NCD .GT. 1 .AND. ESC .NE. ZERO ) THEN DO 30 K = 2, NCD 30 C( NDX(K) ) = C( NDX(K) ) + A(K-1)*ESC ENDIF C(NR) = E C *** SQUARE MATRIX COLUMN MODIFICATIONS *** IF ( NCD .GT. 1 ) THEN C FORM SID, BEGIN SDD DO 60 K = 2, NCD J = NDX(K) DO 50 I = ITOP, IBOT CALL SKYSUB ( NDFREE, IDIAG, I, J, IJV ) CALL SKYSUB ( NDFREE, IDIAG, I, NR, INRV ) IF ( INRV .NE. 0 .AND. S(INRV) .NE. 0.0 ) THEN IF ( IJV .EQ. 0 ) STOP 'INVALID ADDRESS, SKYLCE' C DO NOT MODIFY NR COLUMN, MAY NEED IT LATER SKIP = .FALSE. DO 40 LL = K+1, NCD IF ( I .EQ. NDX(LL) ) SKIP= .TRUE. 40 CONTINUE IF ( (.NOT. SKIP) .AND. I .NE. NR ) 1 S(IJV) = S(IJV) - S(INRV)*A(K-1) ENDIF 50 CONTINUE 60 CONTINUE C COMPLETE SDD DO 80 K = 2, NCD I = NDX(K) DO 70 L = 2, K J = NDX(L) CALL SKYSUB ( NDFREE, IDIAG, I, J, IJV ) CALL SKYSUB ( NDFREE, IDIAG, I, NR, INRV ) IF ( IJV .EQ. 0 .OR. INRV .EQ. 0 ) 1 STOP 'INVALID ADDRESS, SKYLCE' S(IJV) = S(IJV) + SRRP1*A(K-1)*A(L-1) 1 - A(L-1)*S(INRV) 70 CONTINUE 80 CONTINUE ENDIF C *** INSERT CONSTRAINT EQUATION *** C WARNING: NEXT LOOP NOT VALID FOR COUPLED CONSTRAINTS DO 90 I = ITOP, IBOT CALL SKYSUB ( NDFREE, IDIAG, I, NR, INRV ) IF ( INRV .NE. 0 ) S(INRV) = ZERO 90 CONTINUE S(IDIAG(NR)) = 1.0 IF ( NCD .GT. 1 ) THEN DO 100 K = 2, NCD I = NDX(K) CALL SKYSUB ( NDFREE, IDIAG, I, NR, INRV ) IF ( INRV .EQ. 0 ) STOP 'INVALID ADDRESS, SKYLCE' S(INRV) = A(K-1) 100 CONTINUE C *** MODIFICATIONS COMPLETED, CHECK DIAGONAL *** DO 110 K = 2, NCD I = NDX(K) IF ( S(IDIAG(I)) .LE. ZERO ) WRITE (6,*) 1 'NEGATIVE DIAGONAL FOR CONSTRAINT SET', NDX 110 CONTINUE ENDIF RETURN END SUBROUTINE SKYSOL (NDFREE,NOCOEF,IDIAG,S,C,D) C * * * * * * * * * * * * * * * * * * * * * * * * * * C FOWARD AND BACK SUBSTITUTION OF L*D*LT C FACTORIZATION OF SYSTEM EQS S*D=C C * * * * * * * * * * * * * * * * * * * * * * * * * * C S IN SYMMERIC SKYLINE STORAGE VECTOR CDP IMPLICIT REAL*8 (A-H,O-Z) DIMENSION S(NOCOEF), C(NDFREE), D(NDFREE), 1 IDIAG(NDFREE) C NDFREE = TOTAL NUMBER OF SYSTEM DOF C NOCOEF = IDIAG(NDFREE) = NO OF COEFFS IN MATRIX S C IDIAG(I) = LOCATION OF DIAGONAL OF EQ I C S = FACTOR OF SYS SQ MATRIX, FROM SKYFAC C C = SYSTEM COLUMN MATRIX C D = SYSTEM DEGREES OF FREEDOM (RETURNED) C DOT = DOT PROD OF 2 VECTORS, FUNCTION PROG ZERO = 0.0 if (zero.eq.zero) stop 'fatal logic if height=1' C FORWARD SUBSTITUTION D(1) = C(1) DO 100 I = 2,NDFREE IOFF = IDIAG(I) - IDIAG(I-1) - 1 IF ( IOFF.LT.1 ) GO TO 100 ITOP = I - IOFF IS = IDIAG(I-1) + 1 D(I) = C(I) - DOT(IOFF,S(IS),D(ITOP)) 100 CONTINUE C BACK SUBSTITUTION DO 200 I = 1,NDFREE IF ( S(IDIAG(I)).NE.ZERO ) D(I)=D(I)/S(IDIAG(I)) 200 CONTINUE NDFM1 = NDFREE - 1 DO 300 K = 1,NDFM1 I = NDFREE - K + 1 IOFF = IDIAG(I) - IDIAG(I-1) - 1 ITOP = I - IOFF JSTART = ITOP JSTOP = I - 1 IF ( JSTART.GT.JSTOP ) GO TO 300 JD = IDIAG(I-1) - ITOP + 1 DI = D(I) IF ( DI.EQ.ZERO ) GO TO 300 DO 250 J = JSTART,JSTOP D(J) = D(J) - DI*S(J+JD) 250 CONTINUE 300 CONTINUE RETURN END SUBROUTINE SKYSOLVE (A, B, IDIAG, NEQ, FACT, BACK, NOCOEF) C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C PERFORM A =(U)T*D*U FACTORIZATION AND/OR BACKSUBSTITUTION C OF SYMMETRIC POSITIVE DEFINITE SYSTEM OF EQUATIONS C A*X = B C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C A(NA) = UPPER TRIANGULAR COEFFICIENT MATRIX STORED IN C COLUMN FORM (HOLDS D & U ON EXIT) C B(NEQ) = RIGHT SIDE VECTOR (HOLDS X ON EXIT) C IDIAG(NEQ) = ADDRESSES OF DIAGONAL TERMS IN A(NA) C NEQ = NUMBER OF EQUATIONS C FACT = .TRUE. , FACTOR A(NA) C .FALSE. , DO NOT FACTOR A(NA) C BACK = .TRUE. , FORWARD REDUCE B(NEQ) & BACKSUBSTITUTE C .FALSE. , DO NOT FORWARD REDUCE & BACKSUBSTITUTE C CDP IMPLICIT REAL*8 (A-H,O-Z) LOGICAL FACT, BACK DIMENSION A(nocoef), B(neq), IDIAG(neq) PARAMETER ( ZERO = 0.D0 ) C C.... FACTOR A, REDUCE B C JR = 0 DO 600 J = 1, NEQ JD = IDIAG(J) JH = JD - JR IS = J - JH + 2 IF ( JH-2 ) 600, 300, 100 100 IF ( .NOT. FACT ) GO TO 500 IE = J - 1 K = JR + 2 ID = IDIAG(IS - 1) C C.... REDUCE ALL EQUATIONS EXCEPT DIAGONAL C DO 200 I = IS, IE IR = ID ID = IDIAG(I) IH = MIN0(ID-IR-1, I-IS+1) IF ( IH .GT. 0 ) 1 A(K) = A(K) - DOT(IH, A(K-IH), A(ID-IH)) 200 K = K + 1 C C.... REDUCE DIAGONAL TERM C 300 IF ( .NOT. FACT ) GO TO 500 IR = JR + 1 IE = JD - 1 K = J - JD DO 400 I = IR, IE ID = IDIAG(K+I) IF ( A(ID) .EQ. ZERO ) GO TO 400 D = A(I) A(I) = A(I)/A(ID) A(JD) = A(JD) - D*A(I) 400 CONTINUE C C.... REDUCE RHS C 500 IF ( BACK ) B(J) = B(J) - DOT(JH-1, A(JR+1), B(IS-1)) 600 JR = JD IF ( .NOT. BACK ) RETURN C C.... DIVIDE BY DIAGONAL PIVOTS C DO 700 I = 1, NEQ ID = IDIAG(I) IF ( A(ID) .NE. ZERO ) B(I) = B(I)/A(ID) 700 CONTINUE C C.... BACKSUBSTITUTE C J = NEQ JD = IDIAG(J) 800 D = B(J) J = J - 1 IF ( J .LE. 0 ) RETURN JR = IDIAG(J) IF ( JD-JR .LE. 1 ) GO TO 1000 IS = J - JD + JR + 2 K = JR - IS + 1 DO 900 I = IS, J 900 B(I) = B(I) - A(I+K)*D 1000 JD = JR GO TO 800 END SUBROUTINE SKYSTR (NOCOEF, NDFREE, NELFRE, INDEX, 1 IDIAG, S, SS) C * * * * * * * * * * * * * * * * * * * * * * * * * C STORE ELEMENT SQUARE MATRIX TO SYSTEM SQUARE C MATRIX STORED IN SYMMETRIC SKYLINE MODE C * * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8 (A-H,O-Z) DIMENSION SS(NOCOEF), S(NELFRE,NELFRE), 1 INDEX(NELFRE), IDIAG(NDFREE) C NOCOEF = NO COEFF IN SQ MATRIX = IDIAG(NDFREE) C NDFREE = TOTAL NO OF DOF IN SYSTEM C NELFRE = NUMBER OF ELEMENT DEGREES OF FREEDOM C INDEX(I) = SYS DOF NO OF ELEMENT DOF I C IDIAG(I) = LOCATION OF DIAGONAL OF I-TH EQ C S = ELEMENT SQUARE MATRIX C SS = SYS SQ MATRIX IN SKYLINE VECTOR MODE C C LOOP OVER ELEMENT COEFFICIENTS DO 20 J = 1, NELFRE NDXJ = INDEX(J) C ALLOW FOR OMITTED NODES IF ( NDXJ .GT. 0 ) THEN JTEMP = IDIAG(NDXJ) - NDXJ DO 10 I = 1, NELFRE NDXI = INDEX(I) IF ( NDXI .LE. NDXJ .AND. NDXI .GT. 0 ) THEN C FIND SYSTEM COEFF IN VECTOR S NDXV = JTEMP + NDXI C NDXV = IDIAG(AMAX0(NDXI,NDXJ)) C - IABS(NDXJ-NDXI) SS(NDXV) = SS(NDXV) + S(I,J) ENDIF 10 CONTINUE ENDIF 20 CONTINUE RETURN END SUBROUTINE SKYSUB (NDFREE, IDIAG, I, J, IJV) C * * * * * * * * * * * * * * * * * * * * * * * C CONVERT (I,J) FULL SYMMETRIC MATRIX SUBSCRIPTS C TO IJV SUBSCRIPT OF VECTOR SKYLINE STORAGE MODE C * * * * * * * * * * * * * * * * * * * * * * * C ASSUMING SYMM EQS, COLS STORED FROM TOP DOWN DIMENSION IDIAG(NDFREE) C NDFREE = TOTAL NO OF SYSTEM EQUATIONS C IDIAG(I) = LOCATION OF DIAG OF I-TH EQ ID = MAX0 (I,J) IJV = IDIAG(ID) - IABS(I-J) RETURN END SUBROUTINE SKYTAL (NDFREE, IDIAG, J, JTOP, JBOT) C * * * * * * * * * * * * * * * * * * * * * * * * * * C FIND THE TOP AS WELL AS THE (MAXIMUM) BOTTOM C INDEX OF THE SKYLINE OF COL "J" C * * * * * * * * * * * * * * * * * * * * * * * * * * C ASSUMING SYMM EQS, COLS STORED FROM TOP DOWN DIMENSION IDIAG(NDFREE) C JBOT = LAST NON-ZERO TERM LOCATION IN COLUMN J C JTOP = TOP NON-ZERO TERM LOCATION IN COLUMN J C NDFREE = TOTAL NO OF SYSTEM EQUATIONS C IDIAG(I) = LOCATION OF DIAG OF I-TH EQ C C FINDING JTOP IF ( J .GT. 1 ) THEN JTOP = J - ( IDIAG(J) - IDIAG(J-1) ) + 1 ELSE JTOP = 1 ENDIF C FINDING JBOT JBOT = J DO 10 I = J+1 , NDFREE MINI = I - ( IDIAG(I) - IDIAG(I-1) ) + 1 IF ( MINI .LE. J ) JBOT = I 10 CONTINUE RETURN END SUBROUTINE SOLVE (NDFREE, IBW, S, P, D) C * * * * * * * * * * * * * * * * * * * * * * * * * * C FOWARD AND BACK SUBSTITUTION OF SYSTEM EQUATIONS C PART TWO OF CHOLESKY-GAUSSIAN SOLUTION C * * * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8(A-H,O-Z) DIMENSION S(NDFREE,IBW), P(NDFREE), D(NDFREE) C NDFREE = MAX. DEGREES OF FREEDOM IN SYSTEM C IBW = MAXIMUM HALF BANDWIDTH OF THE SYSTEM C S = FACTORED SYS SQ MATRIX FROM SUBR FACTOR C D = SYSTEM DEGREES OF FREEDOM TO BE DETERMINED C P = SYSTEM COLUMN MATRIX (KNOWN) D(1) = P(1) / S(1,1) C--- FOWARD SUBSTITUTION DO 20 I = 2,NDFREE II = I + 1 J = II - IBW IF(II .LE. IBW ) J = 1 IK = I - 1 SUM = 0.0 DO 10 K = J,IK KK = II - K 10 SUM = SUM + S(K,KK)*S(K,1)*D(K) 20 D(I) = ( P(I) - SUM ) / S(I,1) C--- BACK SUBSTITUTION DO 40 NN = 2,NDFREE I = NDFREE + 1 - NN LL = I - 1 J = LL + IBW IF ( J.GT.NDFREE ) J = NDFREE L = I + 1 SUM = 0.0 DO 30 K = L,J KK = K - LL 30 SUM = SUM + S(I,KK)*D(K) 40 D(I) = D(I) - SUM RETURN END FUNCTION START (IG, NSPACE, COORD) C * * * * * * * * * * * * * * * * * * * * * * * * * * C DEFINE STARTING VALUE OF PARAMETER IG IN TERMS OF C COORDINATES OF THE NODE (FOR ITERATIVE SOLUTIONS) C * * * * * * * * * * * * * * * * * * * * * * * * * * C A PROBLEM DEPENDENT ROUTINE CDP IMPLICIT REAL*8(A-H,O-Z) DIMENSION COORD(1,NSPACE) C NSPACE = DIMENSION OF SPACE C COORD = SPATIAL COORDINATE ARRAY OF NODE C .................................................... C ** PROBLEM DEPENDENT START STATEMENTS FOLLOW ** C .................................................... C APPLICATION: LEAST SQ. SOL. OF 2YY''-Y'Y'+4YY=0 C--> STRAIGHT LINE FIT THROUGH TWO BOUNDARY VALUES X = COORD(1,1) START = 0.7162D0*X - 0.125D0 IF ( IG .EQ. 2 ) START = 0.7162D0 RETURN END SUBROUTINE STORCL (NDFREE,NELFRE,INDEX,C,CC) C * * * * * * * * * * * * * * * * * * * * * * * * * * C STORE ELEMENT COLUMN MATRIX IN SYSTEM COLUMN MATRIX C * * * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8(A-H,O-Z) DIMENSION C(NELFRE), CC(NDFREE), INDEX(NELFRE) C INDEX = SYSTEM DOF NOS OF THE ELEMENT DOF C C = ELEMENT COLUMN MATRIX C CC = SYSTEM COLUMN MATRIX C NDFREE = NO DEGREES OF FREEDOM IN THE SYSTEM C NELFRE = NUMBER OF DEGREES OF FREEDOM PER ELEMENT DO 10 I = 1,NELFRE J = INDEX(I) IF ( J .GT. 0 ) CC(J) = CC(J) + C(I) 10 CONTINUE RETURN END SUBROUTINE STORSQ (NDFREE, IBW, NELFRE, INDEX, S, SS) C * * * * * * * * * * * * * * * * * * * * * * * * * * C ADD ELEMENT SQUARE MATRIX TO UPPER HALF BANDWIDTH C OF THE SYMMETRIC SYSTEM SQUARE MATRIX C * * * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8(A-H,O-Z) DIMENSION S(NELFRE,NELFRE), SS(NDFREE,IBW), 1 INDEX(NELFRE) C INDEX = SYSTEM DOF NOS OF THE ELEMENT DOF C S = SQUARE ELEMENT MATRIX C SS = SQUARE SYSTEM MATRIX C NDFREE = DEGREES OF FREEDOM IN THE SYSTEM C IBW = HALF BAND WIDTH INCLUDING THE DIAGONAL C NELFRE = NUMBER OF PARAMETERS (DOF) PER ELEMENT C I,J = ROW AND COLUMN POSITIONS IN THE C UNPACKED SYSTEM MATRIX, RESPECTIVELY C JJ = COLUMN POSITION IN PACKED SYSTEM MATRIX DO 20 L = 1,NELFRE I = INDEX(L) C ALLOW FOR OMITTED NODES IF ( I .GT. 0 ) THEN DO 10 K = 1,NELFRE J = INDEX(K) IF ( J .GT. 0 ) THEN C STORE UPPER BAND ONLY IF ( I .LE. J ) THEN JJ = J - I + 1 SS(I,JJ) = SS(I,JJ) + S(L,K) ENDIF ENDIF 10 CONTINUE ENDIF 20 CONTINUE RETURN END SUBROUTINE STRFUL (NDFREE, NELFRE, S, SS, INDEX) C * * * * * * * * * * * * * * * * * * * * * * * * * * C STORE ELEMENT SQ MATRIX IN FULL SYSTEM SQ MATRIX C * * * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8 (A-H,O-Z) DIMENSION S(NELFRE,NELFRE), SS(NDFREE,NDFREE), 1 INDEX(NELFRE) C NELFRE = NO DEGREES OF FREEDOM PER ELEMENT C NDFREE = TOTAL NO OF SYSTEM DEGREES OF FREEDOM C SS = FULL SYSTEM SQUARE MATRIX C S = FULL ELEMENT SQUARE MATRIX C INDEX = SYSTEM DOF NOS OF ELEMENT PARAMETERS DO 20 I = 1,NELFRE II = INDEX(I) IF ( II .GT. 0 ) THEN DO 10 J = 1,NELFRE JJ = INDEX(J) IF ( JJ .GT. 0 ) THEN SS(II,JJ) = SS(II,JJ) + S(I,J) ENDIF 10 CONTINUE ENDIF 20 CONTINUE RETURN END SUBROUTINE SUMIN (NDFREE, M, NG, CC, TOTAL) C * * * * * * * * * * * * * * * * * * * * * * * * * * C SUM INPUT VALUES IN FORCING VECTOR, CC C * * * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8(A-H,O-Z) PARAMETER ( NCRD = 5, NPRT = 6 ) DIMENSION CC(NDFREE), TOTAL(NG) C NDFREE = TOTAL NUMBER OF SYSTEM DEGREES OF FREEDOM C NG = NUMBER OF PARAMETERS PER NODE C CC = SYSTEM EQUATIONS COLUMN MATRIX C M = TOTAL NUMBER OF NODES IN THE SYSTEM DO 5 I = 1, NG 5 TOTAL(I) = 0.0 WRITE (6,5030) 5030 FORMAT ( /, '*** INPUT SOURCE RESULTANTS ***',/, 1 'DOF SUM') DO 20 I = 1, M DO 30 J = 1, NG IJEQ = NG*(I-1) + J 30 TOTAL(J) = TOTAL(J) + CC(IJEQ) 20 CONTINUE DO 40 J = 1, NG 40 WRITE (6,5040) J, TOTAL(J) 5040 FORMAT ( I3, 2X, 1PE12.4 ) RETURN END SUBROUTINE SYMINV (A, N) C * * * * * * * * * * * * * * * * * * * * * * * C--> INVERT SYMMETRIC MATRIX A(N,N) C * * * * * * * * * * * * * * * * * * * * * * * DIMENSION A(N,N) DO 40 K = 1,N D = A(K,K) IF ( D .EQ. 0.0 ) STOP 'ZERO PIVOT IN SYMINV' DO 10 J = 1, N 10 A(K,J) = -A(K,J)/D DO 30 I = 1, N IF ( I .NE. K ) THEN DO 20 J = 1, N IF ( J .NE. K ) 1 A(I,J) = A(I,J) + A(I,K)*A(K,J) 20 CONTINUE ENDIF 30 A(I,K) = A(I,K)/D 40 A(K,K) = 1.0/D RETURN END SUBROUTINE SYMRUL (NIP, QPT, WT) C * * * * * * * * * * * * * * * * * * * * * * * * * * C SYMMETRICAL QUADRATURE RULES FOR TRIANGLES C IN UNIT COORDINATES C * * * * * * * * * * * * * * * * * * * * * * * * * * PARAMETER ( MAX = 13 ) DIMENSION QPT(2,0:NIP), WT(0:NIP) C NIP = NUMBER OF SYMMETRIC POINTS C QPT = UNIT COORDINATES OF QUADRATURE POINTS C WT = WEIGHTS AT POINTS NQP = NIP IF ( NQP .GT. MAX ) THEN NQP = MAX WRITE (6,*) 'WARNING SYMRUL SET NQP =', MAX ENDIF IF ( NQP .LT. 1 ) STOP 'ERROR IN SYMRUL, STOP' GOTO (1,20,3,4,20,6,7,20,20,20,20,12,13,20), NQP C UNTABULATED DATA 20 STOP 'DATA NOT IN SYMRUL, MAX NQP = 13' C--> ONE POINT RULE 1 WT(1) = 0.500000000 QPT(1,1) = 1.0/3.0 QPT(2,1) = 1.0/3.0 RETURN C--> THREE POINT INTERIOR RULE 3 WT(1) = 0.16666667 WT(2) = WT(1) WT(3) = WT(1) QPT(1,1) = 0.16666667 QPT(2,1) = 0.16666667 QPT(1,2) = 0.66666667 QPT(2,2) = 0.16666667 QPT(1,3) = 0.16666667 QPT(2,3) = 0.66666667 RETURN C--> FOUR POINT INTERIOR (ALL) RULE 4 WT(1) = -27.0/96.0 WT(2) = 25.0/96.0 WT(3) = WT(2) WT(4) = WT(2) QPT(1,1) = 1.0/3.0 QPT(2,1) = 1.0/3.0 QPT(1,2) = 0.20 QPT(2,2) = 0.20 QPT(1,3) = 0.20 QPT(2,3) = 0.60 QPT(1,4) = 0.60 QPT(2,4) = 0.20 RETURN C--> SIX POINT RULE 6 WT(1) = 0.054975872 WT(2) = WT(1) WT(3) = WT(1) WT(4) = 0.111690795 WT(5) = WT(4) WT(6) = WT(4) QPT(1,1) = 0.81684757 QPT(2,1) = 0.091576214 QPT(1,2) = 0.091576214 QPT(2,2) = 0.091576214 QPT(1,3) = 0.091576214 QPT(2,3) = 0.81684757 QPT(1,4) = 0.10810302 QPT(2,4) = 0.44594849 QPT(1,5) = 0.44594849 QPT(2,5) = 0.44594849 QPT(1,6) = 0.44594849 QPT(2,6) = 0.10810302 RETURN C--> SEVEN POINT INTERIOR RULE 7 WT(1) = 0.06296959 WT(2) = 0.06619708 WT(3) = 0.06296959 WT(4) = 0.06619708 WT(5) = 0.06296959 WT(6) = 0.06619708 WT(7) = 0.11250000 QPT(1,1) = 0.10128651 QPT(2,1) = 0.10128651 QPT(1,2) = 0.47014206 QPT(2,2) = 0.05971587 QPT(1,3) = 0.79742699 QPT(2,3) = 0.10128651 QPT(1,4) = 0.47014206 QPT(2,4) = 0.47014206 QPT(1,5) = 0.10128651 QPT(2,5) = 0.79742699 QPT(1,6) = 0.05971587 QPT(2,6) = 0.47014206 QPT(1,7) = 1.0/3.0 QPT(2,7) = 1.0/3.0 RETURN C--> TWELVE POINT RULE 12 WT(1) = 0.025422453 WT(2) = WT(1) WT(3) = WT(1) WT(4) = 0.058393138 WT(5) = WT(4) WT(6) = WT(4) WT(7) = 0.041425538 WT(8) = WT(7) WT(9) = WT(7) WT(10) = WT(7) WT(11) = WT(7) WT(12) = WT(7) QPT(1,1) = 0.87382197 QPT(2,1) = 0.063089014 QPT(1,2) = 0.063089014 QPT(2,2) = 0.063089014 QPT(1,3) = 0.063089014 QPT(2,3) = 0.87382197 QPT(1,4) = 0.50142651 QPT(2,4) = 0.24928675 QPT(1,5) = 0.24928675 QPT(2,5) = 0.24928675 QPT(1,6) = 0.24928675 QPT(2,6) = 0.50142651 QPT(1,7) = 0.63650250 QPT(2,7) = 0.31035245 QPT(1,8) = 0.31035245 QPT(2,8) = 0.053145050 QPT(1,9) = 0.053145050 QPT(2,9) = 0.63650250 QPT(1,10) = 0.63650250 QPT(2,10) = 0.053145050 QPT(1,11) = 0.31035245 QPT(2,11) = 0.63650250 QPT(1,12) = 0.053145050 QPT(2,12) = 0.31035245 RETURN C--> THIRTEEN POINT RULE 13 WT(1) = -0.074785022 WT(2) = 0.087807629 WT(3) = WT(2) WT(4) = WT(2) WT(5) = 0.026673618 WT(6) = WT(5) WT(7) = WT(5) WT(8) = 0.038556880 WT(9) = WT(8) WT(10) = WT(8) WT(11) = WT(8) WT(12) = WT(8) WT(13) = WT(8) QPT(1,1) = 1.0/3.0 QPT(2,1) = 1.0/3.0 QPT(1,2) = 0.47930807 QPT(2,2) = 0.26034597 QPT(1,3) = 0.26034597 QPT(2,3) = 0.26034597 QPT(1,4) = 0.26034597 QPT(2,4) = 0.47930807 QPT(1,5) = 0.86973979 QPT(2,5) = 0.065130103 QPT(1,6) = 0.065130103 QPT(2,6) = 0.065130103 QPT(1,7) = 0.065130103 QPT(2,7) = 0.86973979 QPT(1,8) = 0.63844419 QPT(2,8) = 0.31286550 QPT(1,9) = 0.31286550 QPT(2,9) = 0.048690315 QPT(1,10) = 0.048690315 QPT(2,10) = 0.63844419 QPT(1,11) = 0.63844419 QPT(2,11) = 0.048690315 QPT(1,12) = 0.31286550 QPT(2,12) = 0.63844419 QPT(1,13) = 0.048690315 QPT(2,13) = 0.31286550 RETURN END SUBROUTINE SYSBAN (NE,N,NG,IBW,NODES,LNODE,LMAX) C * * * * * * * * * * * * * * * * * * * * * * * * * C DETERMINE UPPER HALF BAND WIDTH OF SYSTEM C * * * * * * * * * * * * * * * * * * * * * * * * * DIMENSION NODES(NE,N), LNODE(N) C NE = NUMBER OF ELEMENTS IN SYSTEM C N = NUMBER OF NODES PER ELEMENT C NG = NUMBER OF PARAMETERS (DOF) PER ELEMENT C IBW = MAXIMUM HALF BANDWIDTH = LBW MAX C NODES = NODAL INCIDENCES OF ALL ELEMENTS C LNODE = ELEMENT INCIDENCES LIST C LBW = ELEMENT HALF BANDWIDTH C LMAX = LAST ELEMENT CAUSING LBW LMAX = 1 IBW = 1 DO 10 I = 1, NE CALL LNODES (I,NE,N,NODES,LNODE) CALL ELBAND (N,NG,LBW,LNODE) IF ( LBW .GT. IBW ) THEN IBW = LBW LMAX = I ENDIF 10 CONTINUE RETURN END SUBROUTINE TANVEC (N, NPARM, NSPACE, DELTA, 1 COORD, GRAD) C * * * * * * * * * * * * * * * * * * * * * * * * * C CALCULATE THE TANGENT VECTORS AT A LOCAL POINT C ON A PARAMETRIC CURVE OR PARAMETRIC SURFACE C * * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8 (A-H,O-Z) DIMENSION DELTA(NPARM,N), COORD(N,NSPACE), 1 GRAD(NPARM,NSPACE) C N = NUMBER OF NODES PER ELEMENT C NPARM = NUMBER OF PARAMETRIC DIMENSIONS <= NSPACE C NSPACE = DIMENSION OF PHYSICAL SPACE C DELTA = LOCAL DERIVATIVES OF N INTERPOLATION C FUNCTIONS AT POINT OF INTEREST. C COORD = SPATIAL COORDINATES OF ELEMENT'S NODES C GRAD = TANGENT MATRIX = DELTA*COORD C ROW 1 IS DR/DU, 2 DR/DV, 3 DR/DW C FOR NPARM = NSPACE, GRAD = JACOBIAN DO 30 I = 1, NPARM DO 20 J = 1, NSPACE SUM = 0.0 DO 10 K = 1, N SUM = SUM + DELTA(I,K)*COORD(K,J) 10 CONTINUE GRAD(I,J) = SUM 20 CONTINUE 30 CONTINUE RETURN END SUBROUTINE TETRUL (NIP, QPT, WT) C * * * * * * * * * * * * * * * * * * * * * * * * C UNIT COORD QUADRATURE RULES FOR TETRAHEDRA C * * * * * * * * * * * * * * * * * * * * * * * * C REF: M. GELLERT, COMM APP NUM METH, 7,487,1991 C P. KEAST, COMP METH APP MECH ENGR, 55,339-348,1986 C G. BEDROSIAN, IJNME, 35,95-108, 1992 DOUBLE PRECISION A, B, C, D, E, F, G, H, 1 ZERO, HALF, THIRD, SIXTH PARAMETER ( MAX = 11 ) PARAMETER ( A = 0.5854101966249685D0, 1 B = 0.1381966011250105D0, 2 C = 0.5684305841968444D0, 3 D = 0.1438564719343852D0, 4 E = 0.2177650698804054D0, 5 F = 0.0214899534130631D0, 6 G = 0.3994035761667992D0, 7 H = 0.1005964238332008D0 ) PARAMETER ( ZERO = 0.0D0, THIRD = 1.0D0/3.0D0, 1 HALF = 0.5D0, SIXTH = 1.0D0/6.0D0 ) DIMENSION QPT(3,0:NIP), WT(0:NIP) C NIP = NUMBER OF INTEGRATION POINTS C QPT = LOCAL COORD OF QUADRATURE POINT C WT = WEIGHT FOR QUADRATURE POINT N = NIP IF ( N .LT. 1 .OR. N .GT. MAX ) THEN N = MAX WRITE (6,*) ' WARNING: TETRUL SET N =', MAX ENDIF IF ( N .EQ. 1 ) THEN C 1-PT RULE, DEGREE OF PRECISION = 1 WT(1) = 1.0D0/6.0D0 QPT(1,1) = 0.25D0 QPT(2,1) = 0.25D0 QPT(3,1) = 0.25D0 RETURN ELSEIF ( N .EQ. 4 ) THEN C 4-PT RULE, DEGREE OF PRECISION = 2 WT(1) = 1.0D0/24.0D0 WT(2) = 1.0D0/24.0D0 WT(3) = 1.0D0/24.0D0 WT(4) = 1.0D0/24.0D0 QPT(1,1) = A QPT(2,1) = B QPT(3,1) = B QPT(1,2) = B QPT(2,2) = A QPT(3,2) = B QPT(1,3) = B QPT(2,3) = B QPT(3,3) = A QPT(1,4) = B QPT(2,4) = B QPT(3,4) = B RETURN ELSEIF ( N .EQ. 5 ) THEN C 5-PT RULE, DEGREE OF PRECISION = 3 WT(1) = -4.0D0/30. WT(2) = 9.0D0/120. WT(3) = 9.0D0/120. WT(4) = 9.0D0/120. WT(5) = 9.0D0/120. QPT(1,1) = 0.25D0 QPT(2,1) = 0.25D0 QPT(3,1) = 0.25D0 QPT(1,2) = THIRD QPT(2,2) = SIXTH QPT(3,2) = SIXTH QPT(1,3) = SIXTH QPT(2,3) = THIRD QPT(3,3) = SIXTH QPT(1,4) = SIXTH QPT(2,4) = SIXTH QPT(3,4) = THIRD QPT(1,5) = SIXTH QPT(2,5) = SIXTH QPT(3,5) = SIXTH RETURN ELSEIF ( N .EQ. 10 ) THEN C 10-PT RULE, DEGREE OF PRECISION = 3 WT(1) = E/6.0D0 WT(2) = E/6.0D0 WT(3) = E/6.0D0 WT(4) = E/6.0D0 WT(5) = F/6.0D0 WT(6) = F/6.0D0 WT(7) = F/6.0D0 WT(8) = F/6.0D0 WT(9) = F/6.0D0 WT(10) = F/6.0D0 QPT(1,1) = C QPT(2,1) = D QPT(3,1) = D QPT(1,2) = D QPT(2,2) = C QPT(3,2) = D QPT(1,3) = D QPT(2,3) = D QPT(3,3) = C QPT(1,4) = D QPT(2,4) = D QPT(3,4) = D QPT(1,5) = HALF QPT(2,5) = HALF QPT(3,5) = ZERO QPT(1,6) = HALF QPT(2,6) = ZERO QPT(3,6) = HALF QPT(1,7) = HALF QPT(2,7) = ZERO QPT(3,7) = ZERO QPT(1,8) = ZERO QPT(2,8) = HALF QPT(3,8) = HALF QPT(1,9) = ZERO QPT(2,9) = HALF QPT(3,9) = ZERO QPT(1,10) = ZERO QPT(2,10) = ZERO QPT(3,10) = HALF ELSEIF ( N .EQ. 11 ) THEN C 11-PT RULE, DEGREE OF PRECISION = 4 WT(1) = 343.0D0/45000.0D0 WT(2) = 343.0D0/45000.0D0 WT(3) = 343.0D0/45000.0D0 WT(4) = 343.0D0/45000.0D0 WT(5) = 56.0D0/2250.0D0 WT(6) = 56.0D0/2250.0D0 WT(7) = 56.0D0/2250.0D0 WT(8) = 56.0D0/2250.0D0 WT(9) = 56.0D0/2250.0D0 WT(10) = 56.0D0/2250.0D0 WT(11) = -74.0D0/5625.0D0 QPT(1,1) = 11.0D0/14.0D0 QPT(2,1) = 1.0D0/14.0D0 QPT(3,1) = 1.0D0/14.0D0 QPT(1,2) = 1.0D0/14.0D0 QPT(2,2) = 11.0D0/14.0D0 QPT(3,2) = 1.0D0/14.0D0 QPT(1,3) = 1.0D0/14.0D0 QPT(2,3) = 1.0D0/14.0D0 QPT(3,3) = 11.0D0/14.0D0 QPT(1,4) = 1.0D0/14.0D0 QPT(2,4) = 1.0D0/14.0D0 QPT(3,4) = 1.0D0/14.0D0 QPT(1,5) = G QPT(2,5) = G QPT(3,5) = H QPT(1,6) = G QPT(2,6) = H QPT(3,6) = G QPT(1,7) = G QPT(2,7) = H QPT(3,7) = H QPT(1,8) = H QPT(2,8) = G QPT(3,8) = G QPT(1,9) = H QPT(2,9) = G QPT(3,9) = H QPT(1,10) = H QPT(2,10) = H QPT(3,10) = G QPT(1,11) = 0.25D0 QPT(2,11) = 0.25D0 QPT(3,11) = 0.25D0 RETURN ENDIF C NOTE 14 point rule precision 5 also listed, add later RETURN END SUBROUTINE TRINTG (M,N,COORD,VALUE) C * * * * * * * * * * * * * * * * * * * * * * * * * * C 7 POINT QUADRATURE INTEGRATION OF (X**M)(Y**N)(DA) C ON AN ARBITRARY TRIANGLE (AREA COORD) C * * * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8 (A-H,O-Z) DIMENSION COORD(3,2), A1(7), A2(7), A3(7), WT(7) C REFER MEEK, MATRIX STRUCTURAL ANALYSIS DATA WT /0.22500000,3*0.13239415,3*0.12593918/ DATA A1 /0.33333333,2*0.47014206,0.05971587, 1 0.10128651,0.79742699,0.10128651/ DATA A2 /0.33333333,0.05971587,2*0.47014206, 1 2*0.1028651,0.79742699/ DATA A3 /0.33333333,0.470142061,0.05971587, 1 0.47014206,0.79742699,2*0.10128651/ VALUE = 0.0 X1 = COORD(1,1) X2 = COORD(2,1) X3 = COORD(3,1) Y1 = COORD(1,2) Y2 = COORD(2,2) Y3 = COORD(3,2) DO 10 I = 1,7 XP = X1*A1(I) + X2*A2(I) + X3*A3(I) YP = Y1*A1(I) + Y2*A2(I) + Y3*A3(I) 10 VALUE = VALUE + XP**M * YP**N * WT(I) AREA = 0.5*( X1*(Y2-Y3) + X2*(Y3-Y1) +X3*(Y1-Y2) ) VALUE = VALUE*AREA RETURN END SUBROUTINE UNITCO (N,A,W) C * * * * * * * * * * * * * * * * * * * * * * * * * * C CONVERT GAUSS COEFF FROM NATURAL TO UNIT COORDINATES C (SEE SUBROUTINE GAUSCO FOR NATURAL COORDINATE DATA) C * * * * * * * * * * * * * * * * * * * * * * * * * * DIMENSION A(N), W(N) C A = ABSISSAE, INPUT -1 TO 1 ARE 0 TO 1 ON EXIT C N = NUMBER OF TABULATED GAUSS OR LOBATTO PTS IN 1-D C W = QUADRATURE WEIGHTS DO 10 I = 1, N A(I) = (A(I) + 1.D0)*0.5D0 10 W(I) = W(I)*0.5D0 RETURN END SUBROUTINE USERQD (NQP, GPT, GWT, NSPACE, PT, WT) C * * * * * * * * * * * * * * * * * * * * * * * * * * * C USER SUPPLIED QUADRATURE RULE DATA C * * * * * * * * * * * * * * * * * * * * * * * * * * * DIMENSION GPT(0:NQP), GWT(0:NQP), PT(NSPACE,0:NQP), 1 WT(0:NQP) C C ...................................................... C USER SUPPLIED OPTION FOLLOWS C ...................................................... C SPECIAL RULE FOR SINGULARITY ELEMENTS CALL RADAU (NQP, PT, WT) RETURN END SUBROUTINE VECT2D (NTAPE2,XLEN,YLEN,FIRSTX,FIRSTY,DELTAX, 1 DELTAY,XLAST,YLAST,SCALIT,SIZE,NE) C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C CONSTRUCT 2-D VECTOR PLOTS OF VECTORS TABULATED ON NTAPE2 C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C XLEN, YLEN = PLOT LENGTH IN INCHES C FIRSTX, FIRSTY = GLOBAL COORDINATES OF PLOT ORIGIN C DELTAX, DELTAY = CHANGE IN GLOBAL COORD. PER INCH OF PLOT C NE = NO. ELEMENTS C NIP = NO. PLOT PTS IN ELEMENT C SIZE = SIZE OF SYMBOLS, IN INCHES REWIND NTAPE2 CPLT CALL AXIS (0.,0.,'X-COORDS',-8,XLEN,0.0,FIRSTX,DELTAX) CPLT CALL AXIS (0.,0.,'Y-COORDS', 8,YLEN,90.,FIRSTY,DELTAY) C LOOP OVER ELEMENTS DO 30 J = 1, NE READ (NTAPE2) NIP C LOOP OVER VECTOR POINTS DO 40 K = 1, NIP READ (NTAPE2) X, Y, DX, DY C MOVE PEN TO POINT (CONVERT FROM GLOBAL TO INCHES) X = (X-FIRSTX)/DELTAX Y = (Y-FIRSTY)/DELTAY C IS POINT IN REGION OF INTEREST IF ( X.LT.FIRSTX .OR. X.GT.XLAST ) GO TO 40 IF ( Y.LT.FIRSTY .OR. Y.GT.YLAST ) GO TO 40 CPLT CALL PLOT (X,Y,3) C SCALE MAX. COMPONENT TO 1 INCH & FIND ANGLE DX = DX/SCALIT DY = DY/SCALIT ANG = ATAN2(DY,DX)*57.3 - 90. X = X + DX Y = Y + DY VECTOR = SQRT(DX*DX+DY*DY) C DRAW LINE AND ARROW CPLT CALL SYMBOL (X,Y,SIZE,6,ANG,-2) 40 CONTINUE 30 CONTINUE RETURN END SUBROUTINE WRTELM (NE, N, NG, NDFREE, NELFRE, DD, 1 INDEX, NODES, LNODE) C * * * * * * * * * * * * * * * * * * * * * * * * * * C OUTPUT, BY ELEMS, OF CALCULATED DEGREES OF FREEDOM C * * * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8(A-H,O-Z) PARAMETER ( NPRT = 6 ) DIMENSION DD(NDFREE), INDEX(NELFRE), NODES(NE,N), 1 LNODE(N) C NE = NUMBER OF ELEMENTS IN SYSTEM C N = NUMBER NODES PER ELEMENT C NG = NUMBER OF PARAMETERS (DOF) PER NODE C NDFREE = NUMBER DEGREES OF FREEDOM IN SYSTEM C NELFRE = NUMBER DEGREES OF FREEDOM PER ELEMENT C DD = CALCULATED NODAL PARAMETERS (DOF) C INDEX = SYSTEM DOF NUMBERS FOR ELEMENT PARAMETERS C NODES = NODAL INCIDENCES OF ALL ELEMENTS C LNODE = NODAL INCIDENCES OF AN ELEMENT WRITE (NPRT,5000) NG 5000 FORMAT ( /, '*** OUTPUT OF RESULTS ***',/, 1 'ELEMENT, NODE, ', I3,' PARAMETERS' ) DO 20 IE = 1, NE CALL LNODES (IE, NE, N, NODES, LNODE) DO 10 K = 1, N NODE = LNODE(K) C ALLOW FOR OMITTED NODES IF ( NODE .GT. 0 ) THEN CALL INDXPT (NODE,NG,INDEX) WRITE (NPRT,5010) IE, NODE, (DD(INDEX(L)),L=1,NG) 5010 FORMAT (I5, I8, 2X, (6(1X, 1PE12.5)) ) ENDIF 10 CONTINUE 20 CONTINUE RETURN END SUBROUTINE WRTPT (M, NG, NDF, NSPACE, X, DD, INDEX) C * * * * * * * * * * * * * * * * * * * * * * * * * * C OUTPUT, BY NODES, OF CALCULATED DEGREES OF FREEDOM C * * * * * * * * * * * * * * * * * * * * * * * * * * CDP IMPLICIT REAL*8 (A-H,O-Z) PARAMETER ( NPRT = 6 ) DIMENSION X(M,NSPACE), DD(NDF), INDEX(NG) C M = NUMBER OF NODES IN SYSTEM C NG = NUMBER OF PARAMETERS (DOF) PER NODE C NDF = NUMBER OF DOF IN THE SYSTEM C NSPACE = DIMENSION OF SPACE C X = SYSTEM COORDINATES OF ALL NODES C DD = CALCULATED NODAL PARAMETERS C INDEX = SYSTEM DOF NOS OF PARAMETERS ON A NODE WRITE (NPRT,5000) NSPACE, NG 5000 FORMAT( /, '*** OUTPUT OF RESULTS ***',/, 1 'NODE, ',I1,' COORDINATES, ',I2,' PARAMETERS.') DO 10 I = 1, M CALL INDXPT (I,NG,INDEX) WRITE (NPRT,5010) I, ( X(I,L), L=1,NSPACE ), 1 ( DD(INDEX(K)), K=1,NG ) 5010 FORMAT ( I5, (9(1X, 1PE12.5)) ) 10 CONTINUE RETURN END SUBROUTINE ZEROA (N,A) C * * * * * * * * * * * * * * C ZERO A REAL ARRAY A(N) C * * * * * * * * * * * * * * CDP REAL*8 A DIMENSION A(N) DO 10 J = 1,N 10 A(J) = 0.0 RETURN END SUBROUTINE ZEROI (N,I) C * * * * * * * * * * * * * * * * C ZERO AN INTEGER ARRAY I(N) C * * * * * * * * * * * * * * * * DIMENSION I(N) DO 10 J = 1,N 10 I(J) = 0 RETURN END