1 : C CADGSI SOURCE FANDEUR 13/01/29 21:15:10 7683 2 : SUBROUTINE CADGSI 3 : C************************************************************************ 4 : C 5 : C OBJET : 6 : C 7 : C CALCUL DE LA MATRICE MASSE DIAGONALE ---> Creation d'un CHAMPOIN 8 : C Pour les SOMMETS D0=NI ( MASSE LUMPE ) 9 : C Pour les FACES D0=1/2(Vol1 + Vol2) 10 : C Pour les CENTRES D0=Vol Elt 11 : C 12 : C SYNTAXE : 13 : C 14 : C RES = DGSI OBJ1<'IMPR'> ; 15 : C 16 : C OBJ1 : Table DOMAINE 17 : C TYPE ; SOMMET , FACE , CENTRE (par defaut SOMMET) MSOMMET CENTREP1 18 : C 19 : C 20 : C************************************************************************ 21 : IMPLICIT INTEGER(I-N) 22 : IMPLICIT REAL*8 (A-H,O-Z) 23 : -INC CCGEOME 24 : -INC SMCHAML 25 : -INC CCOPTIO 26 : -INC SMELEME 27 : POINTEUR MELEMP.MELEME 28 : -INC SMTABLE 29 : POINTEUR MTABD.MTABLE 30 : -INC SMCOORD 31 : -INC SMLENTI 32 : -INC SMCHPOI 33 : -INC SIZFFB 34 : POINTEUR IZF1.IZFFM,IZH2.IZHR 35 : CHARACTER*8 NOM0,CHAI,LISMO(5),TYPE,TYPC,NOM 36 : DATA LISMO/'SOMMET ','FACE ','CENTRE ','MSOMMET ','CENTREP1'/ 37 : C *************************************************************** 38 : C---------------------------------------------------------------------- 39 : C KPOIN = 0->SOMMET 1-> FACE 2-> CENTRE 3-> CENTREP0 4-> CENTREP1 5-> MSOMMET 40 : C INEFMD : Type formulation INEFMD=1 LINE,=2 MACRO,=3 QUADRATIQUE, INEFMD=4 LINB 41 : C************************************************************************ 42 : 43 : 44 : IKAS=1 45 : IMPR=0 46 : IAXI=0 47 : IF(IFOMOD.EQ.0)IAXI=2 48 : 48 : CALL LITABS('DOMAINE ',MTABD,1,1,IRET) 49 : IF(IRET.EQ.0)THEN 50 : WRITE(6,*)' On attend une table de soustype DOMAINE' 51 : RETURN 52 : ENDIF 53 : 54 : 19 CONTINUE 54 : CALL LIRCHA(CHAI,0,IRET) 55 : IF(IRET.EQ.0)GO TO 20 55 : CALL OPTLI(IP,LISMO,CHAI,5) 56 : IF(IP.EQ.0)THEN 57 : WRITE(6,*)' On attend un mot cle parmi SOMMET FACE CENTRE ', 58 : & 'MSOMMET CENTREP1 ' 59 : RETURN 60 : ENDIF 61 : IKAS=IP 62 : 63 : 20 CONTINUE 64 : 65 : IF(IKAS.EQ.1.OR.IKAS.EQ.4)THEN 66 : C SOMMET et MSOMMET 67 : C SOMMET 68 : IF(IKAS.EQ.1)THEN 69 : TYPE=' ' 69 : CALL ACMO(MTABD,'MAILLAGE',TYPE,MELEME) 70 : IF(TYPE.NE.'MAILLAGE')RETURN 71 : TYPE=' ' 71 : CALL ACMO(MTABD,'SOMMET',TYPE,MELEMS) 72 : IF(TYPE.NE.'MAILLAGE')RETURN 72 : CALL CRCHPT('SOMMET',MELEMS,1,MCHPOI) 73 : ENDIF 74 : C MSOMMET 75 : IF(IKAS.EQ.4)THEN 76 : c write(6,*)' CADGSI: IKAS=4' 77 : TYPE=' ' 77 : CALL ACMO(MTABD,'MMAIL ',TYPE,MELEME) 78 : IF(TYPE.NE.'MAILLAGE')RETURN 79 : TYPE=' ' 79 : CALL ACMO(MTABD,'MSOMMET',TYPE,MELEMS) 80 : IF(TYPE.NE.'MAILLAGE')RETURN 80 : CALL CRCHPT('MSOMMET',MELEMS,1,MCHPOI) 81 : ENDIF 82 : 82 : CALL KRIPAD(MELEMS,MLENTI) 83 : 84 : C CREATION DE LA DIAGONALE 84 : CALL LICHT(MCHPOI,MPOVAL,TYPC,IGEOM) 85 : SEGACT MELEME 86 : NBSOUS=LISOUS(/1) 87 : IF(NBSOUS.EQ.0)NBSOUS=1 88 : C 89 : C BOUCLE SUR LES TYPES D'ELEMENTS ET CALCUL 90 : C 91 : DO 1 KSOUS=1,NBSOUS 92 : IF(NBSOUS.EQ.1)IPT1=MELEME 93 : IF(NBSOUS.GT.1)IPT1=LISOUS(KSOUS) 94 : SEGACT IPT1 95 : 96 : NP=IPT1.NUM(/1) 97 : NEL=IPT1.NUM(/2) 98 : C 99 : NOM0=NOMS(IPT1.ITYPEL)//' ' 100 : IF(INEFMD.EQ.1.AND.IKAS.EQ.4)NOM0=NOMS(IPT1.ITYPEL)//'P1P1' 101 : IF(INEFMD.EQ.2.AND.IKAS.EQ.4)NOM0=NOMS(IPT1.ITYPEL)//'MCF1' 102 : IF(INEFMD.EQ.3.AND.IKAS.EQ.4)NOM0=NOMS(IPT1.ITYPEL)//'PFP1' 103 : c write(6,*)'4 NOM0=',NOM0 103 : CALL KALPBG(NOM0,'FONFORM ',IZFFM) 104 : SEGACT IZFFM*MOD 105 : IZHR=KZHR(1) 106 : SEGACT IZHR*MOD 107 : C 108 : NPG=FN(/2) 109 : NES=GR(/1) 110 : 111 : IF(IMPR.NE.0)THEN 112 : WRITE(6,*)' SUB CADGSI : NES,NP,NPG,IDIM,NEL=' 113 : & ,NES,NP,NPG,IDIM,NEL 114 : ENDIF 115 : C 116 : DO 10 K=1,NEL 117 : C 118 : NPGR=0 119 : IF(IAXI.NE.0)NPGR=NPG 120 : C 121 : DO 12 I=1,NP 122 : J=IPT1.NUM(I,K) 123 : DO 12 N=1,IDIM 124 : XYZ(N,I)=XCOOR((J-1)*(IDIM+1) +N) 125 : 12 CONTINUE 126 : 126 : CALL CALJBC(FN,GR,PG,XYZ,HR,PGSQ,RPG,NES,IDIM,NP,NPG,IAXI,AIRE) 127 : 128 : IF(IMPR.NE.0)THEN 129 : WRITE(6,*)' SUB CADGSI : AIRE=',AIRE 130 : WRITE(6,*)' SUB CADGSI : LER ' 131 : WRITE(6,1001)(IPT1.NUM(I,K),I=1,NP) 132 : WRITE(6,*)' SUB CADGSI : XYZ ' 133 : WRITE(6,1002)((XYZ(N,I),N=1,2),I=1,NP) 134 : ENDIF 135 : C 136 : DO 3 J=1,NP 137 : SJ=0.D0 138 : DO 4 L=1,NPG 139 : SJ=SJ+FN(J,L)*PGSQ(L) 140 : 4 CONTINUE 141 : C SD(J,K)=SJ 142 : JU=LECT(IPT1.NUM(J,K)) 143 : C D0(JU)=D0(JU)+SJ 144 : VPOCHA(JU,1)=VPOCHA(JU,1)+SJ 145 : 3 CONTINUE 146 : C 147 : 10 CONTINUE 148 : 149 : SEGDES IPT1 150 : SEGSUP IZFFM,IZHR 151 : 1 CONTINUE 152 : SEGDES MELEME 153 : SEGSUP MLENTI 154 : SEGDES MPOVAL 155 : 156 : IF(IMPR.NE.0)THEN 157 : WRITE(6,*)' SUB CADGSI : CALCUL DE LA DIAGONALE' 158 : C WRITE(6,1003)(I,VPOCHA(I,1),I=1,NPT) 159 : WRITE(6,*)' FIN DE CADGSI' 160 : ENDIF 161 : 162 : C FACE 163 : ELSEIF(IKAS.EQ.2)THEN 164 : 165 : TYPE=' ' 165 : CALL ACMO(MTABD,'FACE',TYPE,MELEMF) 166 : IF(TYPE.NE.'MAILLAGE')RETURN 167 : TYPE=' ' 167 : CALL ACMO(MTABD,'CENTRE',TYPE,MELEMC) 168 : IF(TYPE.NE.'MAILLAGE')RETURN 168 : CALL LEKTAB(MTABD,'FACEL',MELEME) 169 : IF(MELEME.EQ.0)RETURN 169 : CALL LEKTAB(MTABD,'XXVOLUM',MCHPO1) 170 : IF(MCHPO1.EQ.0)RETURN 171 : 171 : CALL KRIPAD(MELEMC,MLENT1) 171 : CALL KRIPAD(MELEMF,MLENT2) 172 : 173 : C CREATION DE LA DIAGONALE 173 : CALL CRCHPT('FACE',MELEMF,1,MCHPOI) 173 : CALL LICHT(MCHPOI,MPOVAL,TYPC,IGEOM) 173 : CALL LICHT(MCHPO1,MPOVA1,TYPC,IGEOM) 174 : SEGACT MELEME 175 : C 176 : C BOUCLE SUR LES TYPES D'ELEMENTS ET CALCUL 177 : C 178 : NBEL=NUM(/2) 179 : DO 2 K=1,NBEL 180 : I1=NUM(1,K) 181 : I2=NUM(2,K) 182 : I3=NUM(3,K) 183 : I1=MLENT1.LECT(I1) 184 : I2=MLENT2.LECT(I2) 185 : I3=MLENT1.LECT(I3) 186 : V=(MPOVA1.VPOCHA(I1,1)+MPOVA1.VPOCHA(I3,1) )*0.5D0 187 : VPOCHA(I2,1)=V 188 : 2 CONTINUE 189 : 190 : SEGDES MELEME 191 : SEGDES MPOVA1,MPOVAL 192 : SEGSUP MLENT1,MLENT2 193 : 194 : ELSEIF(IKAS.EQ.3)THEN 195 : C CENTRE 195 : CALL LEKTAB(MTABD,'XXVOLUM',MCHPOI) 196 : IF(MCHPOI.EQ.0)RETURN 197 : 198 : ELSEIF(IKAS.EQ.5.OR.IKAS.EQ.6)THEN 199 : C CENTREP1 et CENTREP0 200 : 200 : CALL ACME(MTABD,'INEFMD',INEFMD) 201 : 202 : IF(INEFMD.EQ.1)THEN 203 : C% Le type d'élément fini %m1:8 ne convient pas. 204 : MOTERR( 1: 8) = 'LINE' 204 : CALL ERREUR(927) 205 : RETURN 206 : ENDIF 207 : 208 : TYPE = ' ' 208 : CALL ACMO(MTABD,'XXPSOML',TYPE,MCHELM) 209 : TYPE = ' ' 210 : IF (TYPE.NE.'MCHAML ') THEN 210 : CALL ECROBJ('TABLE',MTABD) 210 : CALL KPSOML 211 : TYPE = 'MCHAML' 211 : CALL LIROBJ(TYPE,MCHELM,1,IRET) 212 : IF (IRET.EQ.0)THEN 213 : NOM='XXPSOML' 214 : GOTO 5000 215 : ENDIF 215 : CALL ECMO(MTABD,'XXPSOML','MCHAML',MCHELM) 216 : ENDIF 217 : SEGACT MCHELM 218 : 219 : TYPE=' ' 220 : IF(INEFMD.EQ.2)THEN 220 : CALL ACMO(MTABD,'MACRO1 ',TYPE,MELEME) 221 : IF(TYPE.NE.'MAILLAGE')RETURN 222 : ELSEIF(INEFMD.EQ.3)THEN 222 : CALL ACMO(MTABD,'MAILLAGE',TYPE,MELEME) 223 : NOM='MAILLAGE' 224 : IF(TYPE.NE.'MAILLAGE')GO TO 5000 225 : ENDIF 226 : 227 : TYPE=' ' 227 : CALL ACMO(MTABD,'CENTREP1',TYPE,MELEMS) 228 : IF(TYPE.NE.'MAILLAGE')THEN 228 : CALL KCTRP1(MTABD,MELEMS,1) 229 : ENDIF 229 : CALL KRIPAD(MELEMS,MLENTI) 229 : CALL ACMO(MTABD,'ELTP1NC ',TYPE,MELEMP) 230 : NOM='ELTP1NC ' 231 : IF(TYPE.NE.'MAILLAGE')GO TO 5000 231 : CALL CRCHPT('CENTREP1',MELEMS,1,MCHPOI) 232 : 233 : 233 : CALL LICHT(MCHPOI,MPOVAL,TYPC,IGEOM) 234 : SEGACT MELEME 235 : NBSOUS=LISOUS(/1) 236 : IF(NBSOUS.EQ.0)NBSOUS=1 237 : NUTOEL=0 238 : 239 : NPTD=VPOCHA(/1) 240 : IES=IDIM 241 : MP10=0 242 : 243 : DO 11 L=1,NBSOUS 244 : IPT1=MELEME 245 : IF(NBSOUS.NE.1)IPT1=LISOUS(L) 246 : SEGACT IPT1 247 : 248 : MCHAML=ICHAML(L) 249 : SEGACT MCHAML 250 : MELVAL=IELVAL(1) 251 : SEGACT MELVAL 252 : 253 : NP =IPT1.NUM(/1) 254 : NBEL=IPT1.NUM(/2) 255 : 256 : IPT2=MELEMP 257 : IF(NBSOUS.NE.1)IPT2=LISOUS(L) 258 : SEGACT IPT2 259 : 260 : IF(INEFMD.EQ.2.AND.IKAS.EQ.5)NOM0=NOMS(IPT1.ITYPEL)//'MCP1' 261 : IF(INEFMD.EQ.3.AND.IKAS.EQ.5)NOM0=NOMS(IPT1.ITYPEL)//'PRP1' 262 : 262 : CALL KALPBG(NOM0,'FONFORM ',IZFFM) 263 : 264 : 265 : SEGACT IZFFM*MOD 266 : IZHR=KZHR(1) 267 : IZH2=KZHR(2) 268 : SEGACT IZHR*MOD,IZH2*MOD 269 : NES=GR(/1) 270 : NPG=GR(/3) 271 : IZF1=KTP(1) 272 : SEGACT IZF1*MOD 273 : MP1=IZF1.FN(/1) 274 : NP = IPT1.NUM(/1) 275 : 276 : DO 21 K=1,NBEL 277 : DO 109 I=1,NP 278 : J=IPT1.NUM(I,K) 279 : JC = (J-1)*(IDIM+1) 280 : DO 109 N=1,IDIM 281 : XYZ(N,I)=XCOOR( JC + N ) 282 : 109 CONTINUE 283 : 283 : CALL CALJBC(FN,GR,PG,XYZ,HR,PGSQ,RPG,NES,IDIM,NP,NPG,IAXI,AIRE) 284 : 285 : DO 39 M=1,MP1 286 : M11=LECT(IPT2.NUM(M,K)) 287 : M1=M+MP10 288 : c IF(KPOIND.EQ.5)M1=M11 289 : 290 : U=0.D0 291 : DO 33 LL=1,NPG 292 : U=U+IZF1.FN(M,LL)*PGSQ(LL) 293 : 33 CONTINUE 294 : 295 : VPOCHA(M1,1)=VPOCHA(M1,1)+U 296 : 39 CONTINUE 297 : 298 : MP10=MP10+MP1 299 : 21 CONTINUE 300 : 301 : SEGSUP IZFFM,IZF1,IZHR,IZH2 302 : 303 : 304 : SEGDES IPT1,MCHAML,MELVAL,IPT2 305 : NUTOEL=NUTOEL+NBEL 306 : 307 : 11 CONTINUE 308 : 309 : SEGSUP MLENTI 310 : 311 : ENDIF 312 : 313 : 314 : SEGDES MTABD,MPOVAL,MCHPOI 314 : CALL ECROBJ('CHPOINT',MCHPOI) 315 : RETURN 316 : 5000 CONTINUE 317 : C Indice %m1:8 : Problème de données détecté dans lektab 318 : IPOINT = 0 319 : MOTERR(1:8) = NOM 319 : CALL ERREUR(792) 320 : RETURN 321 : 1001 FORMAT(20(1X,I5)) 322 : 1002 FORMAT(10(1X,1PE11.4)) 323 : 1003 FORMAT(6(1X,I7,1X,1PE11.4)) 324 : END 325 : 326 :
© Cast3M 2003 - All rights reserved.
Disclaimer