1 : C ENERCA SOURCE CHAT 11/03/16 21:20:40 6902 2 : SUBROUTINE ENERCA(IPMODL,IPCHE1,IPCHE2,IPCHR) 3 : *_______________________________________________________________________ 4 : * 5 : * OPERATEUR DENSITE D'ENERGIE 6 : * 7 : * ENTREES : 8 : * --------- 9 : * 10 : * IPMODL POINTEUR SUR UN MMODEL 11 : * IPCHE1 POINTEUR SUR UN CHAMELEM 12 : * IPCHE2 POINTEUR SUR UN CHAMELEM 13 : * 14 : * 15 : * SORTIE : 16 : * -------- 17 : * 18 : * IPCHR POINTEUR SUR LE CHAMELEM CORRESPONDANT AU PRODUIT 19 : * CONTRACTE DES DEUX PRECEDENTS. 20 : * =0 SI L'OPERATION EST IMPOSSIBLE. 21 : * 22 : * PASSAGE AUX NOUVEAUX CHAMELEM PAR JM CAMPENON LE 01/91 23 : * 24 : *_______________________________________________________________________ 25 : * 26 : IMPLICIT INTEGER(I-N) 27 : IMPLICIT REAL*8(A-H,O-Z) 28 : * 29 : -INC CCOPTIO 30 : -INC CCGEOME 31 : -INC SMMODEL 32 : -INC SMCHAML 33 : -INC SMINTE 34 : * 35 : SEGMENT NOTYPE 36 : CHARACTER*16 TYPE(NBTYPE) 37 : ENDSEGMENT 38 : * 39 : SEGMENT MPTVAL 40 : INTEGER IPOS(NS) ,NSOF(NS) 41 : INTEGER IVAL(NCOSOU) 42 : CHARACTER*16 TYVAL(NCOSOU) 43 : ENDSEGMENT 44 : * 45 : PARAMETER ( NINF=3 ) 46 : INTEGER INFOS(NINF) 47 : CHARACTER*72 MOT1,MOT2 48 : CHARACTER*(NCONCH) CONM 49 : LOGICAL lsupde,lsupco 50 : * 51 : IPCHR=0 52 : * 53 : NHRM=NIFOUR 54 : * 55 : MCHEL1=IPCHE1 56 : MCHEL2=IPCHE2 57 : SEGACT MCHEL1,MCHEL2 58 : MOT1=MCHEL1.TITCHE 59 : MOT2=MCHEL2.TITCHE 60 : IFO1=MCHEL1.IFOCHE 61 : SEGDES MCHEL1,MCHEL2 62 : * 63 : * TEST DE COMPABILITE DES CHAMPS A MULTIPLIER 64 : * 65 : IF(MOT1.EQ.'CONTRAINTES'.AND.MOT2.EQ.'DEFORMATIONS') THEN 66 : IPCHEC = IPCHE1 67 : IPCHED = IPCHE2 68 : ICAS=1 69 : ELSE IF(MOT2.EQ.'CONTRAINTES'.AND.MOT1.EQ.'DEFORMATIONS') THEN 70 : IPCHEC = IPCHE2 71 : IPCHED = IPCHE1 72 : * ERREUR LES CHAMELEM QUE L ON TENTE DE MULTIPLIER SONT INCOMPATIBLES 73 : ELSE 74 : MOTERR(1:8)=MOT1 75 : MOTERR(9:16)=MOT2 75 : CALL ERREUR(175) 76 : RETURN 77 : ENDIF 78 : * 79 : * VERIFICATION DU LIEU SUPPORT DU MCHAML DE CONTRAINTES 80 : * 80 : CALL QUESUP(IPMODL,IPCHEC,5,0,ISUPCO,IRETCO) 81 : IF (ISUPCO.GT.1) RETURN 82 : * 83 : * VERIFICATION DU LIEU SUPPORT DU MCHAML DE DEFORMATIONS 84 : * 84 : CALL QUESUP(IPMODL,IPCHED,5,0,ISUPDE,IRETDE) 85 : IF (ISUPDE.GT.1) RETURN 86 : * 87 : * ACTIVATION DU MODELE 88 : * 89 : MMODEL=IPMODL 90 : SEGACT MMODEL 91 : NSOUS=KMODEL(/1) 92 : * 93 : KEL22 = 0 94 : DO ISOUS=1,NSOUS 95 : IMODEL=KMODEL(ISOUS) 96 : SEGACT,IMODEL 97 : IF (NEFMOD.EQ.22) KEL22 = KEL22+1 98 : ENDDO 99 : * 100 : * CREATION DU CHAMELEM RESULTAT 101 : * 102 : N1=NSOUS-KEL22 103 : N3=6 104 : L1=8 105 : SEGINI MCHELM 106 : TITCHE='SCALAIRE' 107 : IFOCHE=IFO1 108 : * 109 : * DEBUT DE LA BOUCLE SUR LES DIFFERENTES SOUS ZONES 110 : * 111 : isouss=0 112 : DO 200 ISOUS=1,NSOUS 113 : * 114 : * QUELQUES INITIALISATIONS 115 : * 116 : IMODEL=KMODEL(ISOUS) 117 : C* SEGACT IMODEL 118 : 119 : MELE=NEFMOD 120 : if( mele.eq.22 ) go to 200 121 : isouss=isouss+1 122 : 123 : MOSTRS = 0 124 : MODEFO = 0 125 : IVADEF = 0 126 : IVASTR = 0 127 : IPMINT = 0 128 : lsupco=.false. 129 : lsupde=.false. 130 : * 131 : IPMAIL=IMAMOD 132 : CONM =CONMOD 133 : * 134 : * CREATION DU TABLEAU INFO 135 : * 135 : CALL IDENT (IPMAIL,CONM,IPCHEC,IPCHED,INFOS,IRTD) 136 : IF (IRTD.EQ.0) GOTO 9990 137 : * 138 : * INFORMATION SUR L'ELEMENT FINI 139 : * 139 : * CALL ELQUOI (MELE,0,5,IPINF,IMODEL) 140 : * IF (IERR.NE.0) GOTO 9990 141 : MFR=INFELE(13) 142 : IPPORE=0 143 : IF(MFR.EQ.33) IPPORE=NBNNE(NUMGEO(MELE)) 144 : * MINTE=INFELE(11) 145 : minte=infmod(7) 146 : 147 : IPMINT=MINTE 148 : SEGACT,MINTE 149 : * 150 : IMACHE(ISOUSs)=IPMAIL 151 : CONCHE(ISOUSs)=CONMOD 152 : * 153 : INFCHE(ISOUSs,1)=0 154 : INFCHE(ISOUSs,2)=0 155 : INFCHE(ISOUSs,3)=NHRM 156 : INFCHE(ISOUSs,4)=MINTE 157 : INFCHE(ISOUSs,5)=0 158 : INFCHE(ISOUSs,6)=5 159 : * 160 : * RECHERCHE DES NOMS DE COMPOSANTES 161 : * 162 : NBTYPE=1 163 : SEGINI NOTYPE 164 : TYPE(1)='REAL*8' 165 : MOTYPE=NOTYPE 166 : * 167 : if(lnomid(4).ne.0) then 168 : nomid=lnomid(4) 169 : segact nomid 170 : mostrs=nomid 171 : nstr=lesobl(/2) 172 : nfac=lesfac(/2) 173 : else 174 : lsupco=.true. 174 : CALL IDCONT(IMODEL,IFOUR,MOSTRS,NSTR,NFAC) 175 : nomid=mostrs 176 : endif 177 : * 177 : CALL KOMCHA(IPCHEC,IPMAIL,CONM,MOSTRS, 178 : 1 MOTYPE,1,INFOS,3,IVASTR) 179 : SEGDES,NOMID 180 : IF (IERR.NE.0) THEN 181 : SEGSUP NOTYPE 182 : GOTO 9991 183 : ENDIF 183 : IF(ISUPCO.EQ.1)CALL VALCHE(IVASTR,NSTR,IPMINT,IPPORE) 184 : * 185 : if(lnomid(5) .ne.0) then 186 : nomid=lnomid(5) 187 : segact nomid 188 : ndef=lesobl(/2) 189 : modefo=nomid 190 : else 191 : lsupde=.true. 191 : CALL IDDEFO(IMODEL,IFOUR,MODEFO,NDEF,NFAC) 192 : nomid=modefo 193 : endif 193 : CALL KOMCHA(IPCHED,IPMAIL,CONM,MODEFO,MOTYPE, 194 : 1 1,INFOS,3,IVADEF) 195 : SEGDES,NOMID 196 : SEGSUP NOTYPE 197 : IF (IERR.NE.0) GOTO 9992 197 : IF(ISUPDE.EQ.1)CALL VALCHE(IVADEF,NDEF,IPMINT,IPPORE) 198 : * 199 : * RECHERCHE DE LA TAILLE DES MELVAL A ALLOUER 200 : * 201 : NSPTEL=0 202 : NSEL =0 203 : MPTVAL=IVASTR 204 : DO 1 ICOMP=1,NSTR 205 : MELVAL=IVAL(ICOMP) 206 : NSPTEL=MAX(NSPTEL,VELCHE(/1)) 207 : NSEL =MAX(NSEL ,VELCHE(/2)) 208 : 1 CONTINUE 209 : * 210 : NDPTEL=0 211 : NDEL =0 212 : MPTVAL=IVADEF 213 : DO 2 ICOMP=1,NDEF 214 : MELVAL=IVAL(ICOMP) 215 : NDPTEL=MAX(NDPTEL,VELCHE(/1)) 216 : NDEL =MAX(NDEL ,VELCHE(/2)) 217 : 2 CONTINUE 218 : * 219 : N1PTEL=MAX(NSPTEL,NDPTEL) 220 : N1EL =MAX(NSEL ,NDEL ) 221 : N2PTEL=0 222 : N2EL =0 223 : * 224 : N2=1 225 : SEGINI MCHAML 226 : ICHAML(ISOUSs)=MCHAML 227 : NOMCHE(1)='SCAL' 228 : TYPCHE(1)='REAL*8' 229 : SEGINI MELVAL 230 : IELVAL(1)=MELVAL 231 : IPMELV=MELVAL 232 : * 233 : DO 310 IGAU=1,N1PTEL 234 : DO 310 IB=1,N1EL 235 : r_z=0.D0 236 : * 237 : DO 366 ICOMP=1,NDEF 238 : MPTVAL=IVASTR 239 : MELVAL=IVAL(ICOMP) 240 : IGMN=MIN(IGAU,VELCHE(/1)) 241 : IBMN=MIN(IB ,VELCHE(/2)) 242 : XTT1=VELCHE(IGMN,IBMN) 243 : * 244 : MPTVAL=IVADEF 245 : MELVAL=IVAL(ICOMP) 246 : IGMN=MIN(IGAU,VELCHE(/1)) 247 : IBMN=MIN(IB ,VELCHE(/2)) 248 : XTT2=VELCHE(IGMN,IBMN) 249 : * 250 : r_z = r_z + XTT1*XTT2 251 : 366 CONTINUE 252 : MELVAL=IPMELV 253 : VELCHE(IGAU,IB)=r_z 254 : 310 CONTINUE 255 : * 256 : * DESACTIVATION PROPRE A LA GEOMETRIE ISOUS 257 : * 258 : MELVAL=IPMELV 259 : SEGDES MELVAL 260 : SEGDES MCHAML 261 : 9992 CONTINUE 262 : NOMID=MODEFO 263 : if(lsupde)SEGSUP NOMID 264 : IF(ISUPDE.EQ.1)THEN 264 : CALL DTMVAL(IVADEF,3) 265 : ELSE 265 : CALL DTMVAL(IVADEF,1) 266 : ENDIF 267 : 9991 CONTINUE 268 : NOMID=MOSTRS 269 : if(lsupco)SEGSUP NOMID 270 : IF(ISUPCO.EQ.1)THEN 270 : CALL DTMVAL(IVASTR,3) 271 : ELSE 271 : CALL DTMVAL(IVASTR,1) 272 : ENDIF 273 : 9990 CONTINUE 274 : IF (IPMINT.NE.0) SEGDES,MINTE 275 : * 276 : * ERREUR DANS UNE SOUS ZONE : DESACTIVATION ET RETOUR 277 : IF (IERR.NE.0) THEN 278 : SEGSUP MCHELM 279 : IPCHR = 0 280 : GOTO 999 281 : ENDIF 282 : 283 : 200 CONTINUE 284 : 285 : * Fin du sous-programme 286 : SEGDES,MCHELM 287 : IPCHR=MCHELM 288 : * 289 : 999 CONTINUE 290 : DO ISOUS=1,NSOUS 291 : IMODEL=KMODEL(ISOUS) 292 : SEGDES,IMODEL 293 : ENDDO 294 : SEGDES,MMODEL 295 : 296 : RETURN 297 : END 298 : 299 : 300 :
© Cast3M 2003 - All rights reserved.
Disclaimer