1 : C BMTD SOURCE CHAT 11/03/16 21:15:45 6902 2 : SUBROUTINE BMTD 3 : C----------------------------------------------------------------------- 4 : C -1 t 5 : C Calcul du produit B M D CHPcentre 6 : C le résultat est un CHPface 7 : C----------------------------------------------------------------------- 8 : C 9 : C--------------------------- 10 : C Phrase d'appel (GIBIANE) : 11 : C--------------------------- 12 : C 13 : C CHP2 = 'BMTD' MMODEL RIG1 CHP1 ; 14 : C 15 : C------------------------ 16 : C Operandes et resultat : 17 : C------------------------ 18 : C 19 : C MMODEL : MODELE permettant de récuperer la TABLE DOMAINE 20 : C contenant les maillages et les connectivités. 21 : C On attend un modèle DARCY 22 : C RIG1 : Matrices hybrides elementaires de DARCY crees par MHYB. 23 : C CHP1 : CHPO centre à plusieur composantes. 24 : C CHP2 : CHPO face à plusieur composantes dont le support géometrique 25 : C est le maillage de la rigidité les noms des composantes 26 : C sont ceux de CHP1 27 : C 28 : C----------------------------------------------------------------------- 29 : C 30 : C Langage : ESOPE + FORTRAN77 31 : C 32 : C 33 : C----------------------------------------------------------------------- 34 : IMPLICIT INTEGER(I-N) 35 : IMPLICIT REAL*8 (A-H,O-Z) 36 : * 37 : -INC CCOPTIO 38 : -INC SMCOORD 39 : -INC SMCHPOI 40 : -INC SMELEME 41 : -INC SMRIGID 42 : -INC SMTABLE 43 : -INC SMMODEL 44 : * 45 : SEGMENT ICCPR 46 : INTEGER ICPR(NNGOT) 47 : ENDSEGMENT 48 : * 49 : LOGICAL LOGRE,LOGIN 50 : CHARACTER*8 TAPIND,CHARRE,LETYPE 51 : CHARACTER*4 NOMTOT(1) 52 : * 53 : * Initialisations 54 : * 55 : IVALIN = 0 56 : XVALIN = 0.D0 57 : LOGIN = .TRUE. 58 : IOBIN = 0 59 : TAPIND = 'MOT ' 60 : * 61 : * 62 : * Lecture du MMODEL 63 : * 63 : CALL LIROBJ('MMODEL',IPMODE,1,IRET) 64 : IF(IERR.NE.0)RETURN 65 : MMODEL=IPMODE 66 : SEGACT MMODEL 67 : N1=KMODEL(/1) 68 : DO 7 I=1,N1 69 : IMODEL=KMODEL(I) 70 : SEGACT IMODEL 71 : IF(FORMOD(1).NE.'DARCY')THEN 72 : MOTERR(1:16) = 'DARCY ' 72 : CALL ERREUR(719) 73 : RETURN 74 : ENDIF 75 : 7 CONTINUE 76 : C on récupère la table DOMAINE 77 : IPTABL = 0 77 : CALL LEKMOD(MMODEL,IPTABL,IRET) 78 : IF (IERR.NE.0) RETURN 79 : * 79 : CALL LEKTAB(IPTABL,'ELTFA',IOBRE) 80 : IF (IERR.NE.0) RETURN 81 : IELTFA = IOBRE 81 : CALL LEKTAB(IPTABL,'CENTRE',IOBRE) 82 : IF (IERR.NE.0) RETURN 83 : ICENTR = IOBRE 83 : CALL LEKTAB(IPTABL,'FACE',IOBRE) 84 : IF (IERR.NE.0) RETURN 85 : IFACE = IOBRE 86 : * 87 : * Lecture de RIGIDITE 88 : * 88 : CALL LIROBJ('RIGIDITE',IPRIGI,1,IRET) 89 : IF (IERR.NE.0) RETURN 90 : MRIGID = IPRIGI 91 : * 92 : * 93 : * 94 : * Test du sous-type de la matrice de rigiditée récupérée 95 : * 96 : SEGACT MRIGID 97 : LETYPE = MTYMAT 98 : IF (LETYPE.NE.'DARCY') THEN 99 : MOTERR(1:8) = 'RIGIDITE' 100 : MOTERR(9:16) = 'DARCY ' 100 : CALL ERREUR(79) 101 : SEGDES MRIGID 102 : GOTO 100 103 : ENDIF 104 : * 105 : * Controle des pointeurs de MELEME de la rigidité 106 : * 107 : NRIGEL=IRIGEL(/2) 108 : MELEME=IELTFA 109 : SEGACT MELEME 110 : NBSOUS=LISOUS(/1) 111 : IF(NBSOUS.EQ.0)THEN 112 : IF((NRIGEL.NE.1).OR.(IRIGEL(1,1).NE.MELEME))THEN 113 : MOTERR(1:8) = 'DARCY ' 114 : MOTERR(9:16) = 'ELTFA ' 115 : INTERR(1) = 1 115 : CALL ERREUR(698) 116 : SEGDES MRIGID 117 : GOTO 100 118 : ENDIF 119 : ELSE 120 : IF(NRIGEL.NE.NBSOUS)THEN 121 : MOTERR(1:8) = 'DARCY ' 122 : MOTERR(9:16) = 'ELTFA ' 123 : INTERR(1) = 1 123 : CALL ERREUR(698) 124 : SEGDES MRIGID 125 : GOTO 100 126 : ENDIF 127 : DO 10 ISOUS=1,NBSOUS 128 : IF (LISOUS(ISOUS).NE.IRIGEL(1,ISOUS)) THEN 129 : MOTERR(1:8) = 'DARCY ' 130 : MOTERR(9:16) = 'ELTFA ' 131 : INTERR(1) = ISOUS 131 : CALL ERREUR(698) 132 : SEGDES MRIGID 133 : GOTO 100 134 : ENDIF 135 : 10 CONTINUE 136 : ENDIF 136 : CALL LIROBJ('CHPOINT',IPCHC,1,IRET) 137 : IF(IRET.NE.1) RETURN 138 : MCHPO1=IPCHC 139 : NOMTOT(1)=' ' 140 : INDIC=0 141 : NBCOMP=-1 141 : CALL QUEPOI(MCHPO1,ICENTR,INDIC,NBCOMP,NOMTOT) 142 : IF(IERR.NE.0)RETURN 143 : SEGACT MCHPO1 144 : MSOUP1=MCHPO1.IPCHP(1) 145 : SEGACT MSOUP1 146 : MPOVA1=MSOUP1.IPOVAL 147 : SEGACT MPOVA1 148 : * 149 : * Construction de MCHPOI 150 : * 151 : * 152 : IPT2=IFACE 153 : SEGACT IPT2 154 : NPN=IPT2.NUM(/2) 155 : NSOUPO=1 156 : NAT=1 157 : SEGINI MCHPOI 158 : MTYPOI=' ' 159 : MOCHDE=' CHPOIN CREE PAR BMTD ' 160 : IFOPOI=IFOUR 161 : JATTRI(1)=2 162 : NC=NBCOMP 163 : SEGINI MSOUPO 164 : IPCHP(1)=MSOUPO 165 : DO 5 L=1,NBCOMP 166 : NOCOMP(L)=MSOUP1.NOCOMP(L) 167 : NOHARM(L)=MSOUP1.NOHARM(L) 168 : 5 CONTINUE 169 : IGEOC=IFACE 170 : N=NPN 171 : SEGINI MPOVAL 172 : IPOVAL=MPOVAL 173 : NB=N*NC 173 : CALL INITD(VPOCHA,NB,0.D0) 174 : * 175 : * Creation du tableau ICPR 176 : * 177 : IK = 0 178 : NNGOT = XCOOR(/1)/(IDIM+1) 179 : SEGINI ICCPR 180 : C MELEME = IFACE 181 : C SEGACT MELEME 182 : N2 = IPT2.NUM(/2) 183 : DO 15 I2=1,N2 184 : K = IPT2.NUM(1,I2) 185 : IF (ICPR(K).EQ.0) THEN 186 : IK = IK + 1 187 : ICPR(K) = IK 188 : ENDIF 189 : 15 CONTINUE 190 : SEGDES IPT2 191 : C 192 : C Calcul du produit 193 : C 194 : ITELEM=0 195 : MELEME=IELTFA 195 : C call ecmail(meleme) 196 : SEGACT MELEME 197 : IPT1=MELEME 198 : DO 50 ISOUS=1,NRIGEL 199 : IF(NRIGEL.NE.1)IPT1= LISOUS(ISOUS) 200 : SEGACT IPT1 201 : xMATRI=IRIGEL(4,ISOUS) 202 : SEGACT xMATRI 203 : NELRIG=re(/3) 204 : DO 60 IEL=1,NELRIG 205 : ITELEM=ITELEM+1 206 : * XMATRI=IMATTT(IEL) 207 : * SEGACT XMATRI 208 : NLIGRD=RE(/1) 209 : NLIGRP=RE(/2) 210 : DO 40 I=1,NLIGRD 211 : RLIGN=0.D0 212 : DO 30 J=1,NLIGRP 213 : RLIGN=RLIGN+RE(I,J,iel) 214 : 30 CONTINUE 215 : IPOPTS=ICPR(IPT1.NUM(I,IEL)) 216 : DO 20 K=1,NBCOMP 217 : VPOCHA(IPOPTS,K)=VPOCHA(IPOPTS,K)+RLIGN* 218 : * MPOVA1.VPOCHA(ITELEM,K) 219 : 20 CONTINUE 220 : 221 : 40 CONTINUE 222 : * SEGDES XMATRI 223 : 60 CONTINUE 224 : SEGDES xMATRI 225 : SEGDES IPT1 226 : 50 CONTINUE 227 : IF(NRIGEL.NE.1)SEGDES MELEME 228 : SEGDES MRIGID 228 : CALL ECROBJ('CHPOINT',MCHPOI) 229 : * 230 : * Ménage 231 : * 232 : SEGSUP ICCPR 233 : SEGDES MPOVAL,MSOUPO,MCHPOI 234 : SEGDES MPOVA1,MSOUP1,MCHPO1 235 : 100 CONTINUE 236 : RETURN 237 : END 238 : 239 : 240 : 241 : 242 : 243 : 244 : 245 : 246 : 247 : 248 : 249 : 250 : 251 : 252 : 253 : 254 : 255 :
© Cast3M 2003 - All rights reserved.
Disclaimer