1 : C XXSOUR SOURCE MAGN 10/05/18 21:16:42 6675 2 : SUBROUTINE XXSOUR(KPOIND,NOMD4,MCHPO1,XPG,MELEME,MELEMD,SPGD, 3 : & MCHEL4,INEFMD) 4 : IMPLICIT INTEGER(I-N) 5 : IMPLICIT REAL*8 (A-H,O-Z) 6 : C*********************************************************************** 7 : C 8 : C SYNTAXE : 9 : C 10 : C / / 11 : C On calcule | W S do = | Ma NbSb do 12 : C / / 13 : C EN 2D 14 : C elements SEG2 -> Flux 15 : C elements TRI3 -> Source volumique 16 : C elements QUA4 -> Source volumique 17 : C EN 3D 18 : C elements SEG2 -> Pas de sens !! 19 : C elements TRI3 -> Flux 20 : C elements QUA4 -> Flux 21 : C elements CUB8 -> Source volumique 22 : C elements PRI6 -> Source volumique 23 : C elements TET4 -> Source volumique 24 : C 25 : C*********************************************************************** 26 : 27 : -INC CCOPTIO 28 : -INC CCREEL 29 : -INC CCGEOME 30 : -INC SMCHAML 31 : -INC SMCOORD 32 : -INC SMLENTI 33 : -INC SMELEME 34 : POINTEUR MELEMD.MELEME,SPGD.MELEME 35 : -INC SMCHPOI 36 : -INC SMMATRIK 37 : -INC SIZFFB 38 : POINTEUR IZF1.IZFFM,IZH2.IZHR,IZW.IZFFM,IZWH.IZHR 39 : SEGMENT SAJT 40 : REAL*8 AJT(IDIM,IDIM,NPG),RF1(NP,MP,IDIM),SM1(NP,IDIM) 41 : REAL*8 TN1(NP,IDIM),TN2(NP,IDIM) 42 : ENDSEGMENT 43 : 44 : -INC SMLMOTS 45 : CHARACTER*8 TYPE,NOM0,TYPC,MTERR 46 : CHARACTER*4 NOMD4 47 : LOGICAL XPG 48 : C***************************************************************************** 49 : CXXSOUR 50 : C write(6,*)' Debut XXSOUR' 51 : 52 : C***************************************************************************** 53 : C OPTIONS 54 : C KFORM = 0 -> SI 1 -> EF 2 -> VF 3 -> EFMC 55 : C IDCEN = 0->rien 1-> CENTREE 2-> SUPGDC 3-> SUPG 4-> TVISQUEU 5-> CNG 56 : C KPOIN = 0->SOMMET 1-> FACE 2-> CENTRE 3-> CENTREP0 4-> CENTREP1 5-> MSOMMET 57 : C E/ MMODEL : Pointeur de la table contenant l'information cherchée 58 : C /S IPOINT : Pointeur sur la table DOMAINE 59 : C /S INEFMD : Type formulation INEFMD=1 LINE,=2 MACRO,=3 QUADRATIQUE 60 : C INEFMD=4 LINB 61 : 62 : 63 : IF(XPG)THEN 63 : CALL ARRET(0) 64 : ENDIF 65 : 66 : c IK3=0 67 : IAXI=0 68 : IF(IFOMOD.EQ.0)IAXI=2 69 : DEUPI=1.D0 70 : IF(IAXI.NE.0)DEUPI=2.D0*XPI 71 : 71 : CALL LICHT(MCHPO1,MPOVA1,TYPC,IGEOM) 72 : NC=MPOVA1.VPOCHA(/2) 72 : CALL KRIPAD(SPGD,MLENTI) 73 : 74 : SEGACT MELEME 75 : SEGACT MCHEL4 76 : 77 : NKD=0 78 : DO 101 L=1,MAX(1,LISOUS(/1)) 79 : SEGACT MELEMD 80 : IPT1=MELEME 81 : IPT2=MELEMD 82 : IF(LISOUS(/1).NE.0)IPT1=LISOUS(L) 83 : SEGACT IPT1 84 : IF(MELEMD.LISOUS(/1).NE.0)THEN 85 : IPT2=MELEMD.LISOUS(L) 86 : NKD=0 87 : ENDIF 88 : SEGACT IPT2 89 : MP=IPT2.NUM(/1) 90 : 91 : C----------------------------------------------------------------------- 92 : IF(KPOIND.NE.2)THEN 93 : IF(INEFMD.EQ.3)THEN 94 : IF(KPOIND.EQ.3)NOM0=NOMS(IPT1.ITYPEL)//'PRP0' 95 : IF(KPOIND.EQ.4)NOM0=NOMS(IPT1.ITYPEL)//'PRP1' 96 : IF(KPOIND.EQ.5)NOM0=NOMS(IPT1.ITYPEL)//'PFP1' 97 : ELSEIF(INEFMD.EQ.2)THEN 98 : IF(KPOIND.EQ.3)NOM0=NOMS(IPT1.ITYPEL)//'MCP0' 99 : IF(KPOIND.EQ.4)NOM0=NOMS(IPT1.ITYPEL)//'MCP1' 100 : IF(KPOIND.EQ.5)NOM0=NOMS(IPT1.ITYPEL)//'MCF1' 101 : ELSEIF(INEFMD.EQ.1)THEN 102 : IF(KPOIND.EQ.5)NOM0=NOMS(IPT1.ITYPEL)//'P1P1' 103 : ELSEIF(INEFMD.EQ.4)THEN 104 : NOM0=NOMS(IPT1.ITYPEL)//' ' 105 : ENDIF 106 : ENDIF 107 : 108 : IF(KPOIND.EQ.2)THEN 109 : NOM0 = NOMS(IPT1.ITYPEL)//NOMD4 110 : ENDIF 111 : 112 : IF(KPOIND.EQ.0)THEN 113 : NOM0 = NOMS(IPT1.ITYPEL) 114 : NOM0 = NOMS(IPT1.ITYPEL)//NOMD4 115 : ENDIF 116 : C----------------------------------------------------------------------- 117 : c write(6,*)' XXSOUR 1er KALPBG NOM0=',NOM0,IPT1 117 : CALL KALPBG(NOM0,'FONFORM ',IZFFM) 118 : IF(IZFFM.EQ.0)RETURN 119 : SEGACT IZFFM*MOD 120 : IZHR=KZHR(1) 121 : SEGACT IZHR*MOD 122 : IZF1 = KTP(1) 123 : IZH2 = KZHR(2) 124 : IZW = IZF1 125 : IF(KPOIND.EQ.0)IZW=IZFFM 126 : SEGACT IZW*MOD 127 : IF(MP.NE.IZW.FN(/1))THEN 128 : c write(6,*)' Gross problem XXSOUR ' 129 : c write(6,*)' NOM0=',NOM0 ,' NOMD4=',NOMD4 130 : c write(6,*)' MP=',MP,' KPOIND.=',KPOIND,' IZW.FN(/1)=' 131 : c & ,IZW.FN(/1) 132 : ENDIF 133 : 134 : NES=GR(/1) 135 : NPG=GR(/3) 136 : NP = IPT1.NUM(/1) 137 : NBEL=IPT1.NUM(/2) 138 : 139 : SEGINI SAJT 140 : MCHAM4=MCHEL4.ICHAML(L) 141 : SEGACT MCHAM4 142 : 143 : MELVA4=MCHAM4.IELVAL(1) 144 : SEGACT MELVA4 145 : N1PTEL=MELVA4.VELCHE(/1) 146 : N1EL=MELVA4.VELCHE(/2) 147 : c write(6,*)' N1PTEL=',N1PTEL,'N1EL=',N1EL 148 : IF(N1EL.EQ.1)THEN 149 : IK4=1 150 : ELSEIF(N1EL.EQ.NBEL)THEN 151 : IK4=0 152 : ENDIF 153 : c write(6,*)' AVANT 108 NC=',NC,' NBEL=',NBEL,MP,NP,NC 154 : c write(6,*)' AVANT 108 IK4=',IK4,'N1PTEL=',N1PTEL,'N1EL=',N1EL 155 : 156 : c write(6,*)' ' 157 : c write(6,*)' XXSOUR ---------------------------------------' 158 : c nche1=MELVA4.VELCHE(/1) 159 : c nche2=MELVA4.VELCHE(/2) 160 : c write(6,*)' MELVA4=',MELVA4 161 : c write(6,*)' MCHEL4=',MCHEL4,' nche1=',nche1,' nche2=',nche2 162 : c write(6,*)' NC=',NC,' MP=',MP,' NP=',NP,' NPG=',NPG 163 : c write(6,*)' IDIM=',IDIM,' NBEL=',nbel 164 : c write(6,*)' XXSOUR ---------------------------------------' 165 : c write(6,*)' ' 166 : 167 : DO 108 KE=1,NBEL 168 : 169 : NKD=NKD+1 170 : c NK1=KE + IK1*(1 - KE) 171 : c NK2=KE + IK2*(1 - KE) 172 : c NK3=KE + IK3*(1 - KE) 173 : NK4=KE + IK4*(1 - KE) 174 : 175 : DO 109 I=1,NP 176 : J=IPT1.NUM(I,KE) 177 : DO 109 N=1,IDIM 178 : XYZ(N,I)=XCOOR((J-1)*(IDIM+1)+N) 179 : 109 CONTINUE 180 : 180 : CALL CALJBR(FN,GR,PG,XYZ,HR,PGSQ,RPG,NES, 181 : * IDIM,NP,NPG,IAXI,AIRE,AJ,SGN) 182 : 182 : CALL INITD(SM1,(MP*IDIM),0.D0) 183 : 184 : C======================================================================= 185 : 186 : C::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: 187 : C...... Source 188 : DO 710 I=1,MP 189 : U4=0.D0 190 : C1=1.D0 191 : DO 717 N=1,NC 192 : DO 715 LG=1,NPG 193 : WT=IZW.FN(I,LG) 194 : c IF(XPG)THEN 195 : c WT=MELVA3.VELCHE((IDIM+I-1)*NPG+LG,NK3)+IZW.FN(I,LG) 196 : c ENDIF 197 : C4=MELVA4.VELCHE((N-1)*NPG+LG,NK4) 198 : 199 : U4=U4+WT*PGSQ(LG)*C4*DEUPI*RPG(LG) 200 : 715 CONTINUE 201 : SM1(I,N)=SM1(I,N)+ U4 202 : 717 CONTINUE 203 : 710 CONTINUE 204 : C...... Source Fin 205 : C======================================================================= 206 : 207 : 208 : C>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 209 : C ...... Chargement Second membre 210 : DO 911 I=1,MP 211 : I1=LECT(IPT2.NUM(I,KE)) 212 : DO 910 N=1,NC 213 : MPOVA1.VPOCHA(I1,N)=MPOVA1.VPOCHA(I1,N)+SM1(I,N) 214 : 910 CONTINUE 215 : 911 CONTINUE 216 : C<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 217 : 218 : 108 CONTINUE 219 : 220 : SEGDES IPT1,IPT2 221 : SEGSUP MCHAM4,MELVA4 222 : 223 : SEGSUP IZFFM,IZHR,IZF1,IZH2 224 : SEGSUP SAJT 225 : 226 : 101 CONTINUE 227 : SEGDES MPOVA1 228 : SEGSUP MLENTI 229 : SEGSUP MCHEL4 230 : 231 : 232 : c write(6,*)' FIN XXSOUR' 233 : RETURN 234 : 1002 FORMAT(10(1X,1PE11.4)) 235 : 1001 FORMAT(10(1X,I7)) 236 : END 237 : 238 : 239 : 240 : 241 : 242 : 243 : 244 : 245 : 246 : 247 : 248 : 249 : 250 :
© Cast3M 2003 - All rights reserved.
Disclaimer