1 : C FAMORE SOURCE CHAT 11/03/16 21:22:03 6902 2 : SUBROUTINE FAMORE(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 : MOMATR=0 84 : IVAMAT=0 85 : MOCARA=0 86 : IVACAR=0 87 : C 88 : C ON RECUPERE L INFORMATION GENERALE 89 : C 90 : IMODEL=KMODEL(ISOUS) 91 : SEGACT IMODEL 92 : IPMAIL=IMAMOD 93 : CONM =CONMOD 94 : * 95 : MELE=NEFMOD 96 : MELEME=IMAMOD 97 : SEGACT MELEME 98 : NBNN=NUM(/1) 99 : NBELEM=NUM(/2) 100 : C 101 : C TRAITEMENT DU MODELE 102 : C 103 : C* NFOR=FORMOD(/2) 104 : C* NMAT=MATMOD(/2) 105 : C 106 : C NATURE DU MATERIAU 107 : C 107 : C* CALL NOMATE(FORMOD,NFOR,MATMOD,NMAT,CMATE,MATE,INFIBR) 108 : CMATE = CMATEE 109 : MATE = IMATEE 110 : INFIBR = INATUU 111 : C* IF (CMATE.EQ.' ')THEN 111 : C* CALL ERREUR(251) 112 : C* GOTO 9993 113 : C* ENDIF 114 : IF(MATE.NE.1)THEN 114 : CALL ERREUR(635) 115 : GOTO 9993 116 : ENDIF 116 : CALL TEMANF(INFIBR,NIFIBR) 117 : IF((NIFIBR.EQ.0).AND.(INFIBR.NE.0))THEN 117 : CALL ERREUR(636) 118 : GOTO 9993 119 : ENDIF 120 : * 121 : C____________________________________________________________________ 122 : C 123 : C INFORMATION SUR L'ELEMENT FINI 124 : C____________________________________________________________________ 125 : C 125 : * CALL ELQUOI(MELE,0,5,IPINF,IMODEL) 126 : * IF (IERR.NE.0) GOTO 9993 127 : MFR =INFELE(13) 128 : IF (MFR.NE.47)THEN 128 : CALL ERREUR(637) 129 : GOTO 9993 130 : ENDIF 131 : NBG =INFELE(6) 132 : NBGS =INFELE(4) 133 : LRE =INFELE(9) 134 : * MINTE=INFELE(11) 135 : MINTE=INFMOD(7) 136 : IPMINT=MINTE 137 : SEGACT,MINTE 138 : IPPORE=0 139 : IF(MFR.EQ.33) IPPORE=NBNN 140 : C 141 : C CREATION DU TABLEAU INFOS 142 : C 142 : CALL IDENT(IPMAIL,CONM,IPCAR,IPCAR,INFOS,IRTD) 143 : IF (IRTD.EQ.0) GOTO 9992 144 : * 145 : * TRAITEMENT DU CHAMP DE CARACTERISTIQUES MATERIELLES 146 : if(lnomid(6).ne.0) then 147 : nomid=lnomid(6) 148 : segact nomid 149 : momatr=nomid 150 : nmatr=lesobl(/2) 151 : nmatf=lesfac(/2) 152 : lsupma=.false. 153 : else 154 : lsupma=.true. 154 : CALL IDMATR(MFR,IMODEL,MOMATR,NMATR,NMATF) 155 : endif 156 : IF (MOMATR.EQ.0) THEN 157 : MOTERR(1:4)='MATE' 158 : MOTERR(5:8)=NOMTP(MELE) 158 : CALL ERREUR (76) 159 : GOTO 9990 160 : ENDIF 161 : * 162 : IF (NIFIBR.NE.8) THEN 163 : NBTYPE=1 164 : SEGINI NOTYPE 165 : MOTYPE=NOTYPE 166 : TYPE(1)='REAL*8' 167 : * 168 : ELSE 169 : NBTYPE=13 170 : SEGINI NOTYPE 171 : MOTYPE=NOTYPE 172 : DO I=1,NBTYPE 173 : TYPE(I)='REAL*8' 174 : ENDDO 175 : TYPE(10)='POINTEUREVOLUTIO' 176 : TYPE(11)='POINTEUREVOLUTIO' 177 : ENDIF 178 : * 178 : CALL KOMCHA(IPCAR,IPMAIL,CONM,MOMATR,MOTYPE,1, 179 : & INFOS,3,IVAMAT) 180 : SEGSUP NOTYPE 181 : * 182 : IF (IERR.NE.0) GOTO 9990 183 : NMATT=NMATR+NMATF 184 : * 185 : IF (ISUP5.EQ.1) THEN 185 : CALL VALCHE(IVAMAT,NMATT,IPMINT,IPPORE) 186 : IF (IERR.NE.0) THEN 187 : ISUP5=0 188 : GOTO 9990 189 : ENDIF 190 : ENDIF 191 : * 192 : * TRAITEMENT DU CHAMP DE CARACTERISTIQUES GEOMETRIQUES 193 : * 194 : if(lnomid(7).ne.0) then 195 : nomid=lnomid(7) 196 : segact nomid 197 : mocara=nomid 198 : ncara=lesobl(/2) 199 : ncarf=lesfac(/2) 200 : lsupca=.false. 201 : else 202 : lsupca=.true. 202 : CALL IDCARB(MELE,IFOUR,MOCARA,NCARA,NCARF) 203 : endif 204 : * 205 : NBTYPE=1 206 : SEGINI NOTYPE 207 : MOTYPE=NOTYPE 208 : TYPE(1)='REAL*8' 209 : * 209 : CALL KOMCHA(IPCAR,IPMAIL,CONM,MOCARA,MOTYPE,1, 210 : & INFOS,3,IVACAR) 211 : SEGSUP NOTYPE 212 : IF (IERR.NE.0) GOTO 9990 213 : NCARR=NCARA+NCARF 214 : * 215 : IF (ISUP5.EQ.1.AND.MOCARA.NE.0) THEN 215 : CALL VALCHE(IVACAR,NCARR,IPMINT,IPPORE) 216 : IF (IERR.NE.0) THEN 217 : ISUP5=0 218 : GOTO 9990 219 : ENDIF 220 : ENDIF 221 : * 222 : * APPEL AU CALCUL PROPREMENT DIT 223 : * 224 : IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN 224 : CALL FAMO22(MELE,IPMAIL,IPMINT,NBGS, 225 : 1 IVAMAT,IVACAR,NMATT,NCARR, 226 : 2 CRIGI,CMASS) 227 : ELSE 227 : CALL FAMOR2(MELE,IPMAIL,IPMINT,NBGS, 228 : 3 IVAMAT,IVACAR,NMATT,NCARR, 229 : 4 CRIGI,CMASS) 230 : ENDIF 231 : * 232 : 9990 CONTINUE 233 : * 234 : * DESACTIVATION DES SEGMENTS 235 : * 236 : IF(ISUP5.EQ.1)THEN 236 : CALL DTMVAL (IVAMAT,3) 236 : CALL DTMVAL (IVACAR,3) 237 : ELSE 237 : CALL DTMVAL (IVAMAT,1) 237 : CALL DTMVAL (IVACAR,1) 238 : ENDIF 239 : * 240 : IF (MOCARA.NE.0) THEN 241 : NOMID=MOCARA 242 : if(lsupca)SEGSUP NOMID 243 : END IF 244 : * 245 : IF (MOMATR.NE.0) THEN 246 : NOMID=MOMATR 247 : if(lsupma)SEGSUP NOMID 248 : END IF 249 : * 250 : 9992 CONTINUE 251 : SEGDES,MINTE 252 : 9993 CONTINUE 253 : SEGDES MELEME,IMODEL 254 : * 255 : IF (IERR.NE.0) GOTO 888 256 : * 257 : 1000 CONTINUE 258 : * 259 : 888 CONTINUE 260 : SEGDES,MMODEL 261 : * 262 : RETURN 263 : END 264 : 265 : 266 :
© Cast3M 2003 - All rights reserved.
Disclaimer