1 : C FRIGIE SOURCE CHAT 11/03/16 21:23:29 6902 2 : SUBROUTINE FRIGIE(IPMODL,IPCAR,CRIGI,CMASS) 3 : ********************************************************************** 4 : * 5 : * CALCUL DES COMPOSANTES DE LA RIGIDITE (HOOK) ELASTIQUE 6 : * CALCUL DES COMPOSANTES DE LA MATRICE (HOOK) DE MASSE 7 : * ... AU SIGNE PRES 8 : * CONTRIBUTION DE CHAQUE ELEMENT DE CHAQUE SS_ZONE DU MODELE 9 : * DE SECTION 10 : * 11 : ********************************************************************** 12 : * 13 : * ENTREES: 14 : * 15 : * IPMODL = POINTEUR SUR UN OBJET MMODEL 16 : * IPCAR = POINTEUR SUR UN MCHAML DE CARACTERISTIQUES 17 : * 18 : * SORTIES: 19 : * 20 : * CRIGI(12) ELEMENT DE REDUCTION DE LA RIGIDITE 21 : * CMASS(12) ELEMENT DE REDUCTION DE LA MASSE 22 : * 23 : ************************************************************************ 24 : * Pierre Pegon (ISPRA) Juillet/Aout 1993 25 : *********************************************************************** 26 : IMPLICIT INTEGER(I-N) 27 : IMPLICIT REAL*8(A-H,O-Z) 28 : * 29 : -INC CCOPTIO 30 : -INC SMCHAML 31 : -INC SMELEME 32 : -INC SMCOORD 33 : -INC SMMODEL 34 : -INC SMINTE 35 : -INC CCHAMP 36 : C 37 : DIMENSION CRIGI(12),CMASS(12) 38 : * 39 : SEGMENT NOTYPE 40 : CHARACTER*16 TYPE(NBTYPE) 41 : ENDSEGMENT 42 : * 43 : SEGMENT MPTVAL 44 : INTEGER IPOS(NS) ,NSOF(NS) 45 : INTEGER IVAL(NCOSOU) 46 : CHARACTER*16 TYVAL(NCOSOU) 47 : ENDSEGMENT 48 : * 49 : CHARACTER*8 CMATE 50 : CHARACTER*(NCONCH) CONM 51 : CHARACTER*16 MOMODL(10) 52 : PARAMETER ( NINF=3 ) 53 : INTEGER INFOS(NINF) 54 : LOGICAL lsupma,lsupca 55 : C 56 : NHRM=NIFOUR 57 : C 58 : C VERIFICATION DU LIEU SUPPORT DU MCHAML DE CARACTERISTIQUES 59 : C 59 : CALL QUESUP(IPMODL,IPCAR,5,0,ISUP5,IRET5) 60 : IF (ISUP5.GT.1) RETURN 61 : C 62 : C ACTIVATION DU MODELE 63 : C 64 : MMODEL=IPMODL 65 : SEGACT MMODEL 66 : NSOUS=KMODEL(/1) 67 : C 68 : C MISE A ZERO DES RIGIDITES 69 : C 70 : DO IE1=1,12 71 : CRIGI(IE1)=0.D0 72 : CMASS(IE1)=0.D0 73 : ENDDO 74 : C____________________________________________________________________ 75 : C 76 : C DEBUT DE LA BOUCLE SUR LES DIFFERENTES ZONES 77 : C____________________________________________________________________ 78 : C 79 : DO 1000 ISOUS=1,NSOUS 80 : * 81 : * INITIALISATION 82 : * 83 : NMATF=0 84 : NMATR=0 85 : MOMATR=0 86 : IVAMAT=0 87 : NCARA=0 88 : NCARF=0 89 : MOCARA=0 90 : IVACAR=0 91 : C 92 : C ON RECUPERE L INFORMATION GENERALE 93 : C 94 : IMODEL=KMODEL(ISOUS) 95 : SEGACT IMODEL 96 : IPMAIL=IMAMOD 97 : CONM =CONMOD 98 : * 99 : MELE=NEFMOD 100 : MELEME=IMAMOD 101 : C 102 : C TRAITEMENT DU MODELE 103 : C 104 : NFOR=FORMOD(/2) 105 : NMAT=MATMOD(/2) 106 : C 107 : C NATURE DU MATERIAU 108 : C 108 : CALL NOMATE(FORMOD,NFOR,MATMOD,NMAT,CMATE,MATE,INFIBR) 109 : IF (CMATE.EQ.' ')THEN 109 : CALL ERREUR(251) 110 : SEGDES IMODEL,MMODEL 111 : RETURN 112 : ENDIF 113 : IF(MATE.NE.1)THEN 113 : CALL ERREUR(635) 114 : SEGDES IMODEL,MMODEL 115 : RETURN 116 : ENDIF 116 : CALL TEMANF(INFIBR,NIFIBR) 117 : IF((NIFIBR.EQ.0).AND.(INFIBR.NE.0))THEN 117 : CALL ERREUR(636) 118 : SEGDES IMODEL,MMODEL 119 : RETURN 120 : ENDIF 121 : * 122 : SEGACT MELEME 123 : NBNN=NUM(/1) 124 : NBELEM=NUM(/2) 125 : C____________________________________________________________________ 126 : C 127 : C INFORMATION SUR L'ELEMENT FINI 128 : C____________________________________________________________________ 129 : C 129 : * CALL ELQUOI(MELE,0,5,IPINF,IMODEL) 130 : * IF (IERR.NE.0) THEN 131 : * SEGDES IMODEL,MMODEL 132 : * RETURN 133 : * ENDIF 134 : * INFO=IPINF 135 : MFR =INFELE(13) 136 : IF (MFR.NE.47)THEN 136 : CALL ERREUR(637) 137 : SEGDES IMODEL,MMODEL 138 : RETURN 139 : ENDIF 140 : NBG =INFELE(6) 141 : NBGS =INFELE(4) 142 : LRE =INFELE(9) 143 : * MINTE=INFELE(11) 144 : minte=infmod(7) 145 : IPPORE=0 146 : IF(MFR.EQ.33) IPPORE=NBNN 147 : C 148 : C CREATION DU TABLEAU INFOS 149 : C 149 : CALL IDENT(IPMAIL,CONM,IPCAR,IPCAR,INFOS,IRTD) 150 : IF (IRTD.EQ.0)THEN 151 : SEGDES IMODEL,MMODEL 152 : * INFO=IPINF 153 : * SEGSUP INFO 154 : RETURN 155 : ENDIF 156 : IPMINT=MINTE 157 : SEGACT,MINTE 158 : * 159 : * TRAITEMENT DU CHAMP DE CARACTERISTIQUES MATERIELLES 160 : * 161 : if(lnomid(6).ne.0) then 162 : nomid=lnomid(6) 163 : segact nomid 164 : momatr=nomid 165 : nmatr=lesobl(/2) 166 : nmatf=lesfac(/2) 167 : lsupma=.false. 168 : else 169 : lsupma=.true. 169 : CALL IDMATR(MFR,IMODEL,MOMATR,NMATR,NMATF) 170 : endif 171 : IF (MOMATR.EQ.0) THEN 172 : MOTERR(1:4)='MATE' 173 : MOTERR(5:8)=NOMTP(MELE) 173 : CALL ERREUR (76) 174 : GOTO 9990 175 : ENDIF 176 : * 177 : IF (NIFIBR.NE.8) THEN 178 : NBTYPE=1 179 : SEGINI NOTYPE 180 : MOTYPE=NOTYPE 181 : TYPE(1)='REAL*8' 182 : * 183 : ELSE 184 : NBTYPE=13 185 : SEGINI NOTYPE 186 : MOTYPE=NOTYPE 187 : DO I=1,NBTYPE 188 : TYPE(I)='REAL*8' 189 : ENDDO 190 : TYPE(10)='POINTEUREVOLUTIO' 191 : TYPE(11)='POINTEUREVOLUTIO' 192 : * 193 : ENDIF 194 : * 194 : CALL KOMCHA(IPCAR,IPMAIL,CONM,MOMATR,MOTYPE,1, 195 : & INFOS,3,IVAMAT) 196 : SEGSUP NOTYPE 197 : IF (IERR.NE.0) GOTO 9990 198 : NMATT=NMATR+NMATF 199 : * 200 : IF (ISUP5.EQ.1) THEN 200 : CALL VALCHE(IVAMAT,NMATT,IPMINT,IPPORE) 201 : IF (IERR.NE.0) THEN 202 : ISUP5=0 203 : GOTO 9990 204 : ENDIF 205 : ENDIF 206 : * 207 : * TRAITEMENT DU CHAMP DE CARACTERISTIQUES GEOMETRIQUES 208 : * 209 : if(lnomid(7).ne.0) then 210 : nomid=lnomid(7) 211 : segact nomid 212 : mocara=nomid 213 : ncara=lesobl(/2) 214 : ncarf=lesfac(/2) 215 : lsupca=.false. 216 : else 217 : lsupca=.true. 217 : CALL IDCARB(MELE,IFOUR,MOCARA,NCARA,NCARF) 218 : endif 219 : * 220 : NBTYPE=1 221 : SEGINI NOTYPE 222 : MOTYPE=NOTYPE 223 : TYPE(1)='REAL*8' 224 : * 224 : CALL KOMCHA(IPCAR,IPMAIL,CONM,MOCARA,MOTYPE,1, 225 : & INFOS,3,IVACAR) 226 : SEGSUP NOTYPE 227 : IF (IERR.NE.0) GOTO 9990 228 : NCARR=NCARA+NCARF 229 : * 230 : IF (ISUP5.EQ.1.AND.MOCARA.NE.0) THEN 230 : CALL VALCHE(IVACAR,NCARR,IPMINT,IPPORE) 231 : IF (IERR.NE.0) THEN 232 : ISUP5=0 233 : GOTO 9990 234 : ENDIF 235 : ENDIF 236 : * 237 : * APPEL AU CALCUL PROPREMENT DIT 238 : * 239 : IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN 239 : CALL FRIG22(MELE,IPMAIL,MINTE,NBGS, 240 : 1 IVAMAT,IVACAR,NMATT,NCARR, 241 : 2 CRIGI,CMASS) 242 : ELSE 242 : CALL FRIGI2(MELE,IPMAIL,MINTE,NBGS, 243 : 3 IVAMAT,IVACAR,NMATT,NCARR, 244 : 4 CRIGI,CMASS) 245 : ENDIF 246 : * 247 : 9990 CONTINUE 248 : * 249 : * DESACTIVATION DES SEGMENTS 250 : * 251 : SEGDES,MINTE,MELEME,IMODEL 252 : * 253 : IF(ISUP5.EQ.1)THEN 253 : CALL DTMVAL (IVAMAT,3) 253 : CALL DTMVAL (IVACAR,3) 254 : ELSE 254 : CALL DTMVAL (IVAMAT,1) 254 : CALL DTMVAL (IVACAR,1) 255 : ENDIF 256 : * 257 : IF (MOCARA.NE.0) THEN 258 : NOMID=MOCARA 259 : if(lsupca)SEGSUP NOMID 260 : END IF 261 : * 262 : IF (MOMATR.NE.0) THEN 263 : NOMID=MOMATR 264 : if(lsupma)SEGSUP NOMID 265 : END IF 266 : * 267 : * IF (IPINF .NE.0) THEN 268 : * INFO=IPINF 269 : * SEGSUP INFO 270 : * END IF 271 : * 272 : IF (IERR.NE.0) GO TO 888 273 : * 274 : 1000 CONTINUE 275 : * 276 : 888 CONTINUE 277 : SEGDES MMODEL 278 : * 279 : RETURN 280 : END 281 : 282 : 283 :
© Cast3M 2003 - All rights reserved.
Disclaimer