1 : C CCGADV SOURCE GOUNAND 11/04/29 21:15:14 6947 2 : SUBROUTINE CCGADV(LCOF,NOMLOI, 3 : $ FC, 4 : $ IMPR,IRET) 5 : IMPLICIT REAL*8 (A-H,O-Z) 6 : IMPLICIT INTEGER (I-N) 7 : C*********************************************************************** 8 : C NOM : CCGADV 9 : C DESCRIPTION : Calcul de la loi de comportement aux points de Gauss : 10 : C 11 : C 12 : C LANGAGE : ESOPE 13 : C AUTEUR : Stéphane GOUNAND (CEA/DRN/DMT/SEMT/LTMF) 14 : C mél : gounand@semt2.smts.cea.fr 15 : C*********************************************************************** 16 : C APPELES : 17 : C APPELE PAR : 18 : C*********************************************************************** 19 : C ENTREES : 20 : C ENTREES/SORTIES : 21 : C SORTIES : - 22 : C TRAVAIL : 23 : C*********************************************************************** 24 : C VERSION : v1, 04/08/04, version initiale 25 : C HISTORIQUE : v1, 04/08/04, création 26 : C HISTORIQUE : 27 : C HISTORIQUE : 28 : C*********************************************************************** 29 : C Prière de PRENDRE LE TEMPS de compléter les commentaires 30 : C en cas de modification de ce sous-programme afin de faciliter 31 : C la maintenance ! 32 : C*********************************************************************** 33 : -INC CCOPTIO 34 : CBEGININCLUDE SMCHAEL 35 : SEGMENT MCHAEL 36 : POINTEUR IMACHE(N1).MELEME 37 : POINTEUR ICHEVA(N1).MCHEVA 38 : ENDSEGMENT 39 : SEGMENT MCHEVA 40 : REAL*8 VELCHE(NBLIG,NBCOL,N2LIG,N2COL,NBPOI,NBELM) 41 : ENDSEGMENT 42 : SEGMENT LCHEVA 43 : POINTEUR LISCHE(NBCHE).MCHEVA 44 : ENDSEGMENT 45 : CENDINCLUDE SMCHAEL 46 : INTEGER NBLIG,NBCOL,N2LIG,N2COL,NBPOI,NBELM,N1 47 : POINTEUR FC.MCHEVA 48 : POINTEUR LCOF.LCHEVA 49 : POINTEUR JMAJAC.MCHEVA 50 : POINTEUR JMIJAC.MCHEVA 51 : POINTEUR JDTJAC.MCHEVA 52 : CHARACTER*8 NOMLOI 53 : INTEGER ICOF 54 : * 55 : -INC TMXMAT 56 : POINTEUR JAC.MXMAT 57 : POINTEUR JM1.MXMAT 58 : POINTEUR M1.MXMAT 59 : POINTEUR M2.MXMAT 60 : POINTEUR M3.MXMAT 61 : * 62 : INTEGER IMPR,IRET 63 : * 64 : * Executable statements 65 : * 66 : IF (IMPR.GT.1) WRITE(IOIMP,*) 'Entrée dans ccgadv' 67 : C IF (.NOT.(IDIM.EQ.1)) THEN 68 : C WRITE(IOIMP,*) 'IDIM=',IDIM,' ?' 69 : C GOTO 9999 70 : C ENDIF 71 : NLFC=FC.VELCHE(/6) 72 : NPFC=FC.VELCHE(/5) 73 : ICOF=0 74 : * 75 : ICOF=ICOF+1 76 : JMAJAC=LCOF.LISCHE(ICOF) 77 : NLJA=JMAJAC.VELCHE(/6) 78 : NPJA=JMAJAC.VELCHE(/5) 79 : ICOF=ICOF+1 80 : JMIJAC=LCOF.LISCHE(ICOF) 81 : NLJI=JMIJAC.VELCHE(/6) 82 : NPJI=JMIJAC.VELCHE(/5) 83 : ICOF=ICOF+1 84 : JDTJAC=LCOF.LISCHE(ICOF) 85 : NLJD=JDTJAC.VELCHE(/6) 86 : NPJD=JDTJAC.VELCHE(/5) 87 : *g LDIM1=JMAJAC.VELCHE(/3) 88 : *g LDIM2=JMAJAC.VELCHE(/4) 89 : *g IF (LDIM1.NE.IDIM.OR.LDIM2.NE.IDIM) THEN 90 : *g WRITE(IOIMP,*) 'Erreur grave 1' 91 : *g GOTO 9999 92 : *g ENDIF 93 : *g SEGINI,JAC 94 : *g LDIM1=JMIJAC.VELCHE(/3) 95 : *g LDIM2=JMIJAC.VELCHE(/4) 96 : *g IF (LDIM1.NE.IDIM.OR.LDIM2.NE.IDIM) THEN 97 : *g WRITE(IOIMP,*) 'Erreur grave 2' 98 : *g GOTO 9999 99 : *g ENDIF 100 : *g SEGINI,JM1 101 : * 102 : * Objet temporaire 103 : * 104 : *g LDIM1=IDIM 105 : *g LDIM2=IDIM 106 : *g SEGINI,M1 107 : *g SEGINI,M2=M1 108 : *g SEGINI,M3=M1 109 : DO ILFC=1,NLFC 110 : IF (NLJA.EQ.1) THEN 111 : ILJA=1 112 : ELSE 113 : ILJA=ILFC 114 : ENDIF 115 : IF (NLJI.EQ.1) THEN 116 : ILJI=1 117 : ELSE 118 : ILJI=ILFC 119 : ENDIF 120 : IF (NLJD.EQ.1) THEN 121 : ILJD=1 122 : ELSE 123 : ILJD=ILFC 124 : ENDIF 125 : DO IPFC=1,NPFC 126 : IF (NPJA.EQ.1) THEN 127 : IPJA=1 128 : ELSE 129 : IPJA=IPFC 130 : ENDIF 131 : IF (NPJI.EQ.1) THEN 132 : IPJI=1 133 : ELSE 134 : IPJI=IPFC 135 : ENDIF 136 : IF (NPJD.EQ.1) THEN 137 : IPJD=1 138 : ELSE 139 : IPJD=IPFC 140 : ENDIF 140 : C CALL MAMA(JMAJAC.VELCHE(1,1,1,1,IPJA,ILJA),IDIM,IDIM 141 : C $ 'COPIE ', 142 : C $ JAC.XMAT,IDIM,IDIM, 143 : C $ IMPR,IRET) 144 : C IF (IRET.NE.0) GOTO 9999 144 : *g CALL MAMA(JMIJAC.VELCHE(1,1,1,1,IPJI,ILJI),IDIM,IDIM, 145 : *g $ 'COPIE ', 146 : *g $ JM1.XMAT,IDIM,IDIM, 147 : *g $ IMPR,IRET) 148 : *g IF (IRET.NE.0) GOTO 9999 149 : DET =JDTJAC.VELCHE(1,1,1,1,IPJD,ILJD) 150 : SDET =SIGN(1.D0,DET) 151 : IF (NOMLOI.EQ.'VOLORI ') THEN 152 : CONTRI=DET 153 : C ELSEIF (NOMLOI.EQ.'ADAF ') THEN 153 : C CALL ERREUR(5) 154 : CC WRITE(IOIMP,*) 'J-1=',JM1.XMAT(1,1) 155 : CC WRITE(IOIMP,*) 'DET=',DET 156 : CC WRITE(IOIMP,*) 'SDET=',SDET 156 : C CALL MARE(JM1.XMAT,IDIM,IDIM, 157 : C $ 'TRJJT ', 158 : C $ TIJIJT, 159 : C $ IMPR,IRET) 160 : C IF (IRET.NE.0) GOTO 9999 161 : C CONTRI=0.5D0*TIJIJT*DET*SDET 162 : C ELSEIF (NOMLOI(1:4).EQ.'ADAR') THEN 162 : C CALL ERREUR(5) 162 : C CALL CH2INT(NOMLOI(5:5),IDIM1,IMPR,IRET) 163 : C IF (IRET.NE.0) GOTO 9999 163 : C CALL CH2INT(NOMLOI(6:6),IDIM2,IMPR,IRET) 164 : C IF (IRET.NE.0) GOTO 9999 164 : C CALL MAMA(JM1.XMAT,IDIM,IDIM, 165 : C $ 'JJT ', 166 : C $ M1.XMAT,IDIM,IDIM, 167 : C $ IMPR,IRET) 168 : C IF (IRET.NE.0) GOTO 9999 168 : C CALL MARE(JM1.XMAT,IDIM,IDIM, 169 : C $ 'TRJJT ', 170 : C $ TIJIJT, 171 : C $ IMPR,IRET) 172 : C TR1=0.D0 173 : C DO IIDIM=1,IDIM 174 : C TR1=TR1+ 175 : C $ (JM1.XMAT(IIDIM,IDIM1)*M1.XMAT(IDIM2,IIDIM)) 176 : C ENDDO 177 : C TR2=JM1.XMAT(IDIM2,IDIM1) 178 : C CONTRI=((0.5D0*TIJIJT*TR2)-TR1)*DET*SDET 179 : C ELSEIF (NOMLOI(1:4).EQ.'ADAK') THEN 179 : C CALL ERREUR(5) 179 : C CALL CH2INT(NOMLOI(5:5),IDIM1,IMPR,IRET) 180 : C IF (IRET.NE.0) GOTO 9999 180 : C CALL CH2INT(NOMLOI(6:6),IDIM2,IMPR,IRET) 181 : C IF (IRET.NE.0) GOTO 9999 181 : C CALL CH2INT(NOMLOI(7:7),IDIM3,IMPR,IRET) 182 : C IF (IRET.NE.0) GOTO 9999 182 : C CALL CH2INT(NOMLOI(8:8),IDIM4,IMPR,IRET) 183 : C IF (IRET.NE.0) GOTO 9999 183 : C CALL MAMA(JM1.XMAT,IDIM,IDIM, 184 : C $ 'TRANSPOS', 185 : C $ M1.XMAT,IDIM,IDIM, 186 : C $ IMPR,IRET) 187 : C IF (IRET.NE.0) GOTO 9999 188 : C WRITE(IOIMP,*) 'transpos' 189 : C SEGPRT,JM1 190 : C SEGPRT,M1 190 : C CALL MAMA(M1.XMAT,IDIM,IDIM, 191 : C $ 'JJT ', 192 : C $ M2.XMAT,IDIM,IDIM, 193 : C $ IMPR,IRET) 194 : C IF (IRET.NE.0) GOTO 9999 195 : C WRITE(IOIMP,*) 'JJT' 196 : C SEGPRT,M1 197 : C SEGPRT,M2 197 : C CALL MARE(JM1.XMAT,IDIM,IDIM, 198 : C $ 'TRJJT ', 199 : C $ TIJIJT, 200 : C $ IMPR,IRET) 201 : C IF (IRET.NE.0) GOTO 9999 202 : C WRITE(IOIMP,*) 'trace JJT' 203 : C SEGPRT,JM1 204 : C WRITE(IOIMP,*) 'TRJJT=',TIJIJT 205 : C XX=-0.5D0*TIJIJT 205 : C CALL REMA(XX,IDIM,IDIM, 206 : C $ 'DIAGONAL', 207 : C $ M1.XMAT, 208 : C $ IMPR,IRET) 209 : C IF (IRET.NE.0) GOTO 9999 210 : C WRITE(IOIMP,*) 'diagonal' 211 : C WRITE(IOIMP,*) 'XX=',XX 212 : C SEGPRT,M1 212 : C CALL MAMAMA(M1.XMAT,IDIM,IDIM,M2.XMAT,IDIM,IDIM, 213 : C $ 'PLUS ', 214 : C $ M3.XMAT,IDIM,IDIM, 215 : C $ IMPR,IRET) 216 : C IF (IRET.NE.0) GOTO 9999 217 : C STOP 16 218 : C TR1=0.D0 219 : C SEGPRT,M1 220 : C SEGPRT,M2 221 : C SEGPRT,M3 222 : C DO IIDIM=1,IDIM 223 : C TR1=TR1+(M3.XMAT(IDIM1,IIDIM)*JM1.XMAT(IDIM4,IIDIM) 224 : C $ *JM1.XMAT(IDIM2,IDIM3)) 225 : C ENDDO 226 : C WRITE(IOIMP,*) 'TR1=',TR1 227 : C WRITE(IOIMP,*) 'DET=',DET 228 : C WRITE(IOIMP,*) 'SDET=',SDET 229 : C CONTRI=TR1*DET*SDET 230 : ELSE 231 : WRITE(IOIMP,*) 'Erreur grave' 232 : GOTO 9999 233 : ENDIF 234 : FC.VELCHE(1,1,1,1,IPFC,ILFC)= 235 : $ FC.VELCHE(1,1,1,1,IPFC,ILFC)+ 236 : $ CONTRI 237 : ENDDO 238 : ENDDO 239 : *g SEGSUP,M3 240 : *g SEGSUP,M2 241 : *g SEGSUP,M1 242 : *g SEGSUP,JM1 243 : *g SEGSUP,JAC 244 : * 245 : * Normal termination 246 : * 247 : IRET=0 248 : RETURN 249 : * 250 : * Format handling 251 : * 252 : * 253 : * Error handling 254 : * 255 : 9999 CONTINUE 256 : IRET=1 257 : WRITE(IOIMP,*) 'An error was detected in subroutine ccgadv' 258 : RETURN 259 : * 260 : * End of subroutine CCGADV 261 : * 262 : END 263 : 264 : 265 :
© Cast3M 2003 - All rights reserved.
Disclaimer