1 : C ADETAT SOURCE KICH 12/06/05 21:15:00 7382 2 : subroutine adetat 3 : implicit real*8(a-h,o-Z) 4 : implicit integer (i-n) 5 : * 6 : * on ene travaille que sur les formulation mecanique et poreux 7 : * et LIAISON (kich) 8 : 9 : -INC CCOPTIO 10 : -INC SMCHAML 11 : -INC SMCHPOI 12 : -INC SMMODEL 13 : -INC SMCHARG 14 : -INC SMTABLE 15 : segment limode(0) 16 : parameter (nnonom=11, nnoind=8, nnofor=5) 17 : character*22 indic(nnoind) 18 : dimension ilo(nnoind) 19 : character*16 mformu(nnofor) 20 : character*8 ctyp,mtyp,chai1,chai2 21 : logical ibo 22 : character*4 init(1),nomc,nonom(nnonom) 23 : data nonom/'MECA','DIMP','TIMP','DEFI','TECO', 24 : $ 'TERA','Q ','REAC','CIMP','UIMP','FORC' / 25 : data init/'NOUV'/ 26 : data indic /'DEPLACEMENTS ','CONTRAINTES ', 27 : & 'TEMPERATURES ','VARIABLES_INTERNES ', 28 : & 'DEFINELA ','PROPORTIONS_PHASE ', 29 : & 'CONCENTRATIONS ','POTENTIELS_ELECTRIQUES'/ 30 : data ilo / 12, 11, 12, 18, 8, 17, 14, 22 / 31 : data mformu /'MECANIQUE ','POREUX ', 32 : & 'LIAISON ','DIFFUSION ', 33 : & 'ELECTROSTATIQUE '/ 34 : 34 : call lirmot(init,1,initia,0) 35 : if(initia.eq.0)then 36 : mchelm=0 36 : call lirobj('MCHAML',mchelm,1,iretou) 37 : if(ierr.ne.0) return 38 : segini,mchel2=mchelm 39 : n1=mchel2.ichaml(/1) 40 : n3=mchel2.infche(/2) 41 : l1=16 42 : else 43 : n1=0 44 : n3=6 45 : l1=16 46 : segini mchel2 47 : mchel2.ifoche=ifour 48 : endif 49 : mchel2.TITCHE='cree par adetat' 49 : call lirobj ('MMODEL',mmodel,1,iretou) 50 : if (ierr.ne.0) then 51 : segsup,mchel2 52 : return 53 : endif 54 : 55 : n1io=n1 56 : itrouv=0 57 : SEGACT MMODEL 58 : NSOUS=MMODEL.KMODEL(/1) 59 : segini limode 60 : do im = 1,NSOUS 61 : imodel = kmodel(im) 62 : segact imodel 63 : limode(**) = imodel 64 : if (formod(1).eq.'MELANGE') then 65 : if (ivamod(/1).ge.1) then 66 : itrouv=1 67 : do ivm1 = 1,ivamod(/1) 68 : if (tymode(ivm1).eq.'IMODEL') then 69 : limode(**) = ivamod(ivm1) 70 : endif 71 : enddo 72 : endif 73 : endif 74 : enddo 75 : if (itrouv.eq.0) go to 1162 76 : segdes mmodel 77 : * test non redondance 78 : N1 = 1 79 : if (limode(/1).gt.1) then 80 : do 1161 it1 = limode(/1),2,-1 81 : imode1 = limode(it1) 82 : segact imode1 83 : do it2 = (it1 - 1) ,1,-1 84 : imode2 = limode(it2) 85 : segact imode2 86 : if (imode1.imamod.eq.imode2.imamod.and. 87 : & imode1.conmod.eq.imode2.conmod) then 88 : limode(it1) = 0 89 : goto 1161 90 : endif 91 : enddo 92 : N1 = N1 + 1 93 : 1161 continue 94 : endif 95 : 96 : is1 = 0 97 : if (limode(/1).gt.0) then 98 : segini,mmodel 99 : do is = 1,limode(/1) 100 : if (limode(is).gt.0) then 101 : is1 = is1 + 1 102 : kmodel(is1) = limode(is) 103 : endif 104 : enddo 105 : else 106 : endif 107 : 1162 continue 108 : segsup limode 109 : mmode1=mmodel 110 : N1=NSOUS 111 : NZON=0 112 : 113 : * on compte combien de formulations incluses dans mformu 114 : DO 1119 I=1,NSOUS 115 : IMODEL=MMODE1.KMODEL(I) 116 : SEGACT IMODEL 117 : NFOR=FORMOD(/2) 118 : IF(NFOR.EQ.1) THEN 118 : CALL PLACE(mformu,nnofor,iplac,FORMOD(1)) 119 : if (iplac.EQ.0) GOTO 1119 120 : ELSE IF(NFOR.EQ.2) THEN 120 : CALL PLACE(mformu,2,iplac,FORMOD(1)) 121 : if (iplac.EQ.0) GOTO 1119 121 : CALL PLACE(mformu,2,iplac,FORMOD(2)) 122 : if (iplac.EQ.0) GOTO 1119 123 : ELSE 124 : GO TO 1119 125 : ENDIF 126 : * on vient ici pour prendre les sous modeles 127 : NZON=NZON+1 128 : 1119 CONTINUE 129 : *on recommence 130 : mmodel=mmode1 131 : if( nzon.ne.nsous.and.nzon.ne.0) then 132 : n1=nzon 133 : nzon=0 134 : segini mmodel 135 : DO 1129 I=1,NSOUS 136 : IMODEL=MMODE1.KMODEL(I) 137 : NFOR=FORMOD(/2) 138 : IF(NFOR.EQ.1) THEN 138 : CALL PLACE(mformu,nnofor,iplac,FORMOD(1)) 139 : if (iplac.EQ.0) GOTO 1129 140 : ELSE IF(NFOR.EQ.2) THEN 140 : CALL PLACE(mformu,2,iplac,FORMOD(1)) 141 : if (iplac.EQ.0) GOTO 1129 141 : CALL PLACE(mformu,2,iplac,FORMOD(2)) 142 : if (iplac.EQ.0) GOTO 1129 143 : ELSE 144 : GO TO 1129 145 : ENDIF 146 : * on vient ici pour prendre les sous modeles 147 : NZON=NZON+1 148 : KMODEL(NZON)=IMODEL 149 : SEGDES IMODEL 150 : 1129 continue 151 : segdes mmode1 152 : endif 153 : NSOUS=n1 154 : if(ierr.ne.0) return 155 : n1 = n1io 156 : do 1 i = 1, 1000 157 : ctyp=' ' 157 : CALL QUETYP(CTYP,0,IRETOU) 158 : * write(6,*) ' iretou ctyp' , iretou,ctyp 159 : if(iretou.eq.0) go to 2 160 : if(ctyp.eq.'FLOTTANT'.or.ctyp.eq.'ENTIER') then 160 : call lirree(xva,1,iret) 161 : ctyp='FLOTTANT' 161 : call lircha(nomc,1,iretou) 162 : elseif(ctyp.eq.'MOT' ) then 162 : call lircha(nomc,1,iretou) 162 : call lirree(xva,1,iret) 163 : ctyp='FLOTTANT' 164 : else 164 : call lirobj (ctyp,ipo,1,iretou) 165 : endif 166 : if(ierr.ne.0) return 167 : 168 : if(ctyp.eq.'CHPOINT') then 168 : CALL CHAME1(0,MMODEL,IPO,' ',Ipche2,5) 169 : IF (IERR.NE.0) RETURN 170 : ipo=ipche2 171 : elseif(ctyp.eq.'FLOTTANT') then 171 : call ecrcha('STRESSES') 171 : call ecrree(xva) 171 : call ecrcha(nomc) 171 : call ecrobj('MMODEL',mmodel) 171 : call ecrcha('CHML') 171 : call manuel 172 : if(ierr.ne.0) return 172 : call lirobj('MCHAML',ipo,1,iretou) 173 : elseif(ctyp.eq.'CHARGEME') then 174 : mcharg=ipo 174 : call lirree(xva,1,iret) 175 : if(ierr.ne.0) then 176 : return 177 : endif 178 : segact mcharg 179 : ika=0 180 : do 10 k=1,kcharg(/1) 181 : nomc=chanom(k) 182 : do ka=1,nnonom 183 : if( nomc.eq.nonom(ka) ) go to 10 184 : enddo 185 : * write(6,*) ' adetat nomc ', nomc 186 : ika=ika+1 186 : call ecrcha(nomc) 186 : call ecrree (xva) 186 : call ecrobj ('CHARGEME',mcharg) 186 : call tire 187 : segact mcharg 187 : call quetyp(ctyp,1,iretou) 188 : if(ierr.ne.0) return 188 : call lirobj(ctyp,ipa,1,iretou) 189 : ipche2=ipa 190 : if(ctyp.eq.'CHPOINT') then 190 : CALL CHAME1(0,MMODEL,IPA,' ',Ipche2,5) 191 : IF (IERR.NE.0) RETURN 192 : elseif (ctyp.eq.'MCHAML') then 193 : * 194 : * AM 21/5/08 195 : * SI C'EST UN MCHAML, ON LE REDUIT D'ABORD SUR LE MODELE 196 : * SI CE N'EST PAS POSSIBLE, ON VA EN 10 197 : * 197 : CALL REDUAF(IPA,MMODEL,IPA2,0,IRET,KERRE) 198 : IF(IRET.EQ.0) THEN 199 : GO TO 10 200 : ENDIF 201 : * 201 : CALL CHASUP(MMODEL,IPA2,IPche2,IRET,5) 202 : endif 203 : mchel3=ipche2 204 : segact mchel3 205 : n13= mchel3.ichaml(/1) 206 : n33= mchel3.infche(/2) 207 : iy=n1 208 : n1 = n1 + n13 209 : n3= max(n3,n33) 210 : segadj mchel2 211 : do kk=1,n13 212 : mchel2.conche(iy+kk)=mchel3.conche(kk) 213 : mchel2.ichaml(iy+kk)=mchel3.ichaml(kk) 214 : mchel2.imache(iy+kk)=mchel3.imache(kk) 215 : do jk=1,n33 216 : mchel2.infche(iy+kk,jk)=mchel3.infche(kk,jk) 217 : enddo 218 : enddo 219 : 10 continue 220 : segdes mcharg 221 : go to 1 222 : elseif(ctyp.eq.'TABLE') then 223 : ika=0 224 : mtable=ipo 225 : segact mtable 226 : ika=0 227 : do 11 k=1,nnoind 228 : mtyp=' ' 228 : call ACCTAB(mtable,'MOT ',IJ,XJ,indic(k)(1:ilo(k)),ibo,IU, 229 : $ MTYP,IK,XK,CHAI1,IBO,IPA) 230 : segact mtable 231 : if(MTYP.EQ.' ') go to 11 232 : if(MTYP.eq.'CHPOINT ') then 232 : CALL CHAME1(0,MMODEL,IPA,' ',Ipche2,5) 233 : IF (IERR.NE.0) RETURN 234 : elseif(mtyp.eq.'MCHAML' ) then 235 : * 236 : * AM 21/5/08 237 : * SI C'EST UN MCHAML, ON LE REDUIT D'ABORD SUR LE MODELE 238 : * SI CE N'EST PAS POSSIBLE, ON VA EN 11 239 : * 239 : CALL REDUAF(IPA,MMODEL,IPA2,0,IRET,KERRE) 240 : IF(IRET.EQ.0) THEN 241 : GO TO 11 242 : ENDIF 243 : * 243 : CALL CHASUP(MMODEL,IPA2,IPche2,IRET,5) 244 : else 245 : go to 11 246 : endif 247 : mchel3=ipche2 248 : segact mchel3 249 : n13= mchel3.ichaml(/1) 250 : n33= mchel3.infche(/2) 251 : iy=n1 252 : n1 = n1 + n13 253 : n3= max(n3,n33) 254 : segadj mchel2 255 : do kk=1,n13 256 : mchel2.conche(iy+kk)=mchel3.conche(kk) 257 : mchel2.ichaml(iy+kk)=mchel3.ichaml(kk) 258 : mchel2.imache(iy+kk)=mchel3.imache(kk) 259 : do jk=1,n33 260 : mchel2.infche(iy+kk,jk)=mchel3.infche(kk,jk) 261 : enddo 262 : enddo 263 : 11 continue 264 : segdes mtable 265 : go to 1 266 : endif 267 : mchel3=ipo 268 : * PV 268 : CALL CHASUP(MMODEL,mchel3,mchpv,IRET,5) 268 : IF (IRET.NE.0) CALL ERREUR(IRET) 269 : if (ierr.ne.0) return 270 : mchel3=mchpv 271 : segact mchel3 272 : n13= mchel3.ichaml(/1) 273 : n33= mchel3.infche(/2) 274 : iy=n1 275 : n1 = n1 + n13 276 : n3= max(n3,n33) 277 : segadj mchel2 278 : do kk=1,n13 279 : mchel2.conche(iy+kk)=mchel3.conche(kk) 280 : mchel2.ichaml(iy+kk)=mchel3.ichaml(kk) 281 : mchel2.imache(iy+kk)=mchel3.imache(kk) 282 : do jk=1,n33 283 : mchel2.infche(iy+kk,jk)=mchel3.infche(kk,jk) 284 : enddo 285 : enddo 286 : 1 continue 287 : 2 continue 288 : if( n1.eq.0) then 288 : * call erreur (19) 288 : call ecrobj('MCHAML',mchel2) 289 : else 290 : * on va essayer de regrouper les supports de chamelem car plusieurs 291 : * opérateurs partent du principes que si un modèle à n sous -zones le 292 : * chamelem doit avoir le meme nombre de sous zones 293 : * 294 : iprio=5 294 : * call zpchel (mchel2,1) 294 : call confor(mchel2,mchel1, mmodel,iprio) 294 : * call zpchel( mchel1,1) 294 : call ecrobj('MCHAML',mchel1) 295 : endif 296 : return 297 : end 298 : 299 : 300 : 301 :
© Cast3M 2003 - All rights reserved.
Disclaimer