1 : C COMOUW SOURCE FANDEUR 12/07/18 21:15:30 7435 2 : SUBROUTINE COMOUW(iqmod,ipcon,INDESO,ipil,iwrk52,iwrk53, 3 : &iretou,iwr522) 4 : *------------------------------------------------- 5 : * identifie les melval de la pile 6 : * - recherche d abord ceux lies au modele 7 : * - puis tous les autres rang 8 : * les active 9 : * !!!!!!! 10 : * points delicats : evite de passer certaines composantes de 11 : * constituants differents de celui du modele : 12 : * dans tous les cas, caracteristiques materiau et geometrique, 13 : * de plus pour la mecanique, contraintes, 14 : * variables internes et deformations inelastiques. 15 : * cependant pour les autres on croise les doigts en esperant que les noms 16 : * de composantes correspondent a un seul constituant 17 : * pas de garde fou 18 : * puis suivant les formulations cree les deche associes 19 : * aux noms de composantes des mchaml attendus en sortie 20 : * (le rang est INDESO) 21 : *------------------------------------------------- 22 : IMPLICIT INTEGER(I-N) 23 : IMPLICIT REAL*8(A-H,O-Z) 24 : -INC CCOPTIO 25 : -INC SMMODEL 26 : -INC SMCHAML 27 : -INC DECHE 28 : logical nouvid 29 : c 30 : nouvid = .true. 31 : lilcon = ipcon 32 : wrk53 = iwrk53 33 : c 34 : imodel = iqmod 35 : 36 : *------------------------------------------------- 36 : call comou2(iqmod,INDESO,ipil,iwrk52,iwrk53,iwr522) 37 : 38 : liluc = ipil 39 : iiluc= liluc(/1) 40 : ijluc = iiluc 41 : wrk52 = iwrk52 42 : wrk522 = iwr522 43 : nexo = exova0(/1) 44 : c 45 : do icon = 1,lilcon(/1) 46 : deche = lilcon(icon) 47 : 48 : C* Cas du test pouvant arriver ? 49 : if (deche.LE.0) GOTO 40 50 : * write (6,*) ' comouw condec ',condec,' conmod ',conmod 51 : * recherche du nom de composante parmi celles qui existent 52 : * 53 : do juc = 1,ijluc 54 : 55 : domdec = liluc(juc) 56 : ** segact domdec*nomod 57 : 58 : nomid = jnomid 59 : C Cas du test ci-dessous puvant arriver ? 60 : if (nomid.le.0) goto 35 61 : nobl = lesobl(/2) 62 : nfac = lesfac(/2) 63 : pilnec = jilnec 64 : ** write(6,*)' juc domdec nomid', juc ,domdec,nomid 65 : ** segact nomid*nomod 66 : ** segact pilnec*mod 67 : * write(6,*) 'nomid ', juc,domdec, nomid , nobl 68 : if (nobl.gt.0) then 69 : do 30 jm =1,nobl 70 : if (nomdec.ne.lesobl(jm)) goto 30 71 : if (juc.eq.13.or.juc.eq.14) then 72 : if (condec.eq.conmod) then 73 : pilobl(jm,indec)=deche 74 : melval = ieldec 75 : segact melval 76 : goto 40 77 : endif 78 : if (FORMOD(1).EQ.'MELANGE'.and.cmate.eq.'PARALLEL' 79 : &.and.indec.eq.indeso) then 80 : segini,dec1=deche 81 : dec1.condec=conmod 82 : * write(6,*) nomdec,indec,condec,conmod 83 : pilobl(jm,indec)=dec1 84 : goto 40 85 : endif 86 : elseif (FORMOD(1).EQ.'MECANIQUE'.and. 87 : & (juc.eq.11.or.juc.eq.20.or.juc.eq.24)) then 88 : if (condec.eq.conmod) then 89 : pilobl(jm,indec)=deche 90 : melval = ieldec 91 : segact melval 92 : ** segact melval*nomod 93 : goto 40 94 : endif 95 : else 96 : pilobl(jm,indec)=deche 97 : melval = ieldec 98 : segact melval 99 : goto 40 100 : endif 101 : 30 continue 102 : endif 103 : if (nfac.gt.0) then 104 : do 31 jm =1,nfac 105 : if (nomdec.ne.lesfac(jm)) goto 31 106 : if (juc.eq.13.or.juc.eq.14) then 107 : if (condec.eq.conmod) then 108 : pilfac(jm,indec)=deche 109 : melval = ieldec 110 : segact melval 111 : goto 40 112 : endif 113 : elseif (FORMOD(1).EQ.'MECANIQUE'.and. 114 : & (juc.eq.11.or.juc.eq.20.or.juc.eq.24)) then 115 : if (condec.eq.conmod) then 116 : pilfac(jm,indec)=deche 117 : melval = ieldec 118 : segact melval 119 : goto 40 120 : endif 121 : else 122 : pilfac(jm,indec)=deche 123 : melval = ieldec 124 : segact melval 125 : goto 40 126 : endif 127 : 31 continue 128 : endif 129 : 130 : ******** segdes nomid,pilnec 131 : 35 continue 132 : *********** segdes domdec 133 : enddo 134 : 135 : * pas dans les listes : reajuster wrk52 136 : 137 : nsca = scal0(/1) 138 : ndep = depl0(/1) 139 : nfor = forc0(/1) 140 : ngra = grad0(/1) 141 : nstrs = SIG0(/1) 142 : ndefo = DEPST(/1) 143 : ncara = XMAT(/1) 144 : ncarb = XCARB(/1) 145 : ntur = ture0(/1) 146 : npri = prin0(/1) 147 : nmah = maho0(/1) 148 : nhot = hota0(/1) 149 : nvari = VAR0(/1) 150 : ngrf = graf0(/1) 151 : nrhi = rhas0(/1) 152 : ndein = DEFP(/1) 153 : nparex=PAREX0(/1) 154 : * 155 : if (nouvid) then 156 : nouvid = .false. 157 : * creation d un nomid et du pilnec 158 : nbrobl=1 159 : nbrfac = 0 160 : segini nomid 161 : lesobl(1) = nomdec 162 : **** segdes nomid 163 : segini domdec 164 : ijluc=ijluc+1 165 : if(ijluc.gt.iiluc) then 166 : iiluc=iiluc+1 167 : segadj liluc 168 : endif 169 : liluc(ijluc)=domdec 170 : jnomid = nomid 171 : mobl = 1 172 : mfac = 0 173 : mran = INDESO 174 : segini pilnec 175 : jilnec = pilnec 176 : pilobl(1,indec) = deche 177 : melval = ieldec 178 : ****** segact melval*nomod 179 : segact melval 180 : nexo = nexo + 1 181 : ******* segdes pilnec 182 : * 183 : segadj wrk52,wrk522 184 : typexo(nexo) = typdec 185 : conexo(nexo) = condec 186 : nomexo(nexo) = nomdec 187 : c write(6,*) ' comouw ajout 1 ', pilnec ,domdec,nomid, icon 188 : c write(6,*) 'suite',mobl,deche, nomdec, nexo ,liluc(/1) 189 : goto 40 190 : 191 : else 192 : knmid = ijluc 193 : domdec = liluc(knmid) 194 : *pv segact domdec*mod 195 : c write(6,*) 'ajouts' ,deche,nomdec,domdec,jnomid,icon 196 : nomid = jnomid 197 : *pv segact nomid*mod 198 : nbrobl = lesobl(/2) + 1 199 : nbrfac = 0 200 : segadj nomid 201 : jnomid = nomid 202 : lesobl(nbrobl) = nomdec 203 : pilnec = jilnec 204 : *pv segact pilnec*mod 205 : mobl = nbrobl 206 : mfac = 0 207 : mran = indeso 208 : segadj pilnec 209 : jilnec = pilnec 210 : pilobl(mobl,indec) = deche 211 : melval = ieldec 212 : segact melval 213 : ******** segact melval*nomod 214 : nexo = nexo + 1 215 : segadj wrk52,wrk522 216 : typexo(nexo) = typdec 217 : conexo(nexo) = condec 218 : nomexo(nexo) = nomdec 219 : * write(6,*) ' comouw ajout 2 ', pilnec ,nomid 220 : * write(6,*) 'suite',mobl,deche, nomdec, melval,nexo ,knmid 221 : ******** segdes nomid,pilnec,domdec 222 : goto 40 223 : endif 224 : 225 : moterr(1:16) = condec 226 : moterr(17:24) = nomdec 227 : interr(1) = 1 228 : * write(6,*) ' comouw : pb classer ' , nomdec , deche 228 : call erreur(943) 229 : return 230 : 231 : 40 continue 232 : enddo 233 : * 234 : *------------------------------------------------- 235 : c 236 : ipil = liluc 237 : iwrk52 = wrk52 238 : c 239 : RETURN 240 : END 241 : 242 :
© Cast3M 2003 - All rights reserved.
Disclaimer