1 : C PHAJ SOURCE CHAT 11/03/16 21:28:54 6902 2 : subroutine phaj 3 : IMPLICIT INTEGER(I-N) 4 : IMPLICIT REAL*8 (A-H,O-Z) 5 : * 6 : * création des "jeux" a associer aux matrices de blocages pour le 7 : * changement de phase 8 : * en entrée : objet modele , chamelem de temperature de changement 9 : * de phase et temperature initiale, matrice de blocages 10 : * 11 : -INC CCOPTIO 12 : -INC SMELEME 13 : -INC SMMODEL 14 : -INC SMRIGID 15 : -INC SMCOORD 16 : -INC SMCHPOI 17 : -INC SMCHAML 18 : segment icpr(XCOOR(/1)/(idim+1)) 19 : segment icpr1(XCOOR(/1)/(idim+1)) 20 : segment icpr2(XCOOR(/1)/(idim+1)) 21 : segment icpr3(XCOOR(/1)/(idim+1)) 22 : segment itvr 23 : real*8 tvr(IB) 24 : endsegment 25 : segment ide(ib) 25 : call lirobj('MMODEL',mmodel,1,iretou) 26 : if(ierr.ne.0) return 26 : call lirobj('MCHAML',mchelm,1,iretou) 27 : if(ierr.ne.0) return 27 : call lirobj('CHPOINT',mchpoi,1,iretou) 28 : if(ierr.ne.0) return 28 : call lirobj('RIGIDITE',mrigid,1,iretou) 29 : segact mmodel,mchelm,mrigid 30 : * on recherche la temperature de fusion 31 : nbsou=kmodel(/1) 32 : segini icpr,icpr1,icpr2,icpr3 33 : * on compte combien de point aux maximum pour creer un tableau de 34 : * maillage pour le chpoint de FLX et un tableau de valeur mpoval 35 : ib=0 36 : do 100 i=1,nbsou 37 : imodel=kmodel(i) 38 : segact imodel 39 : meleme=imamod 40 : segact meleme 41 : do 101 mel=1,num(/2) 42 : do 101 npo=1,num(/1) 43 : ia = num(npo,mel) 44 : if(icpr(ia).eq.0) then 45 : ib=ib+1 46 : icpr(ia)=ib 47 : endif 48 : 101 continue 49 : segdes meleme 50 : 100 continue 51 : * 52 : * reperage du chpoint de temperature initiales 53 : * 54 : segact mchpoi 55 : inon=0 56 : ive=0 57 : do 400 nso=1,ipchp(/1) 58 : msoup1= ipchp(nso) 59 : segact msoup1 60 : do 401 nco=1,msoup1.nocomp(/2) 61 : if(msoup1.nocomp(nco).EQ.'T') go to 402 62 : 401 continue 63 : inon=inon+1 64 : go to 400 65 : moterr(1:4) = 'T ' 65 : call erreur (181) 66 : return 67 : 402 continue 68 : ipt3 = msoup1.igeoc 69 : segact ipt3 70 : do 404 nbe=1,ipt3.num(/2) 71 : ia= ipt3.num(1,nbe) 72 : ive=ive+1 73 : icpr1(ia)=ive 74 : icpr2(ia)=msoup1.ipoval 75 : icpr3(ia)=nco 76 : 404 continue 77 : mpova1=msoup1.ipoval 78 : segact mpova1 79 : 400 continue 80 : if(inon.eq.ipchp(/1)) then 81 : moterr(1:4) = 'T ' 81 : call erreur (181) 82 : return 83 : endif 84 : * fin reperage du chpoint 85 : nbsous=0 86 : nbref=0 87 : nbnn=1 88 : nbelem=ib 89 : * write(6,*) 'nbelem nbnn nbref nbsous',nbelem,nbnn,nbref,nbsous 90 : segini ipt4 91 : * write(6,*) 'sortie de segini' 92 : n=nbelem 93 : nc=1 94 : nat=1 95 : nsoupo=1 96 : segini mpoval,msoupo,itvr,ide,mchpo1 97 : mchpo1.mochde='chpoint créé par sub PHAJ' 98 : mchpo1.mtypoi='jeux' 99 : mchpo1.ipchp(1)=msoupo 100 : mchpo1.jattri(1)=2 101 : mchpo1.ifopoi=ifour 102 : igeoc=ipt4 103 : nocomp(1)='FLX' 104 : noharm(1)=nifour 105 : ipoval=mpoval 106 : * boucle sur les sous zones du model pour creer les matrices de 107 : * blocages 108 : idd=0 109 : do 1 i=1,nbsou 110 : imodel=kmodel(i) 111 : meleme=imamod 112 : * on recherche la temperature de fusion 113 : do 51 mchm=1,imache(/1) 114 : if( imache(mchm) . eq. meleme) then 115 : mchaml=ichaml(mchm) 116 : go to 52 117 : endif 118 : 51 continue 118 : call erreur ( 472) 119 : return 120 : 52 continue 121 : segact mchaml 122 : do 56 n2=1,nomche(/2) 123 : if( nomche(n2).eq.'TPHA') then 124 : melval=ielval(n2) 125 : go to 57 126 : endif 127 : 56 continue 128 : moterr(1:8) = 'TPHA' 128 : call erreur ( 677) 129 : return 130 : 57 continue 131 : segact melval 132 : if(velche(/1)+velche(/2).ne.2) then 132 : call erreur(922) 133 : return 134 : endif 135 : tt = velche(1,1) 136 : * write(6,*)' temperature touvée de changement de phase ', tt 137 : segdes melval 138 : ipt2=irigel(1,i) 138 : * call impp1(meleme,ipt2) 138 : * call ecmail(ipt2,0) 139 : 140 : segact ipt2 141 : * remplissage du chpoint 142 : do 70 mel=1,ipt2.num(/2) 143 : iaa = ipt2.num(2,mel) 144 : icc= icpr(iaa) 145 : * write(6,*) 'mel iaa, icc icpr(1(iaa),icpr(iaa)tt' , 146 : * $ iaa, icc, icpr1(iaa),icpr3(iaa),tt 147 : if(ide(icc).ne.0) then 148 : if(tvr(icc).ne.tt) then 148 : call erreur (921) 149 : return 150 : endif 151 : go to 70 152 : endif 153 : ide(icc)=1 154 : tvr(icc)=tt 155 : mpova1=icpr2(iaa) 156 : * write(6,*) ' mpova1 ' , mpova1 157 : if(mpova1.eq.0) then 158 : tdec = 0.d0 159 : * write(6,*) 'phaj: on passe par la si T0 pas defini !' 160 : else 161 : tdec = mpova1.vpocha(icpr1(iaa),icpr3(iaa)) 162 : endif 163 : idd = idd+1 164 : ipt4.num(1,idd)=ipt2.num(1,mel) 165 : tjeu= tt-tdec 166 : if( abs(tjeu) . le . 1.e-4 ) tjeu=0.; 167 : vpocha(idd,1)= tjeu 168 : * write(6,*) ' noeud valeurs ', ipt4.num(1,idd), tt-tdec,tjeu 169 : 70 continue 170 : 1 continue 171 : segdes mrigid,mmodel 172 : nbnn=1 173 : nbelem=idd 174 : n=idd 175 : nc=1 176 : segadj ipt4 177 : segadj mpoval 178 : segdes mchpo1,msoupo,mpoval,ipt4 179 : segsup icpr,itvr,ide,icpr1,icpr2,icpr3 180 : do 410 k=1,ipchp(/1) 181 : msoupo=ipchp(k) 182 : meleme=igeoc 183 : segdes meleme 184 : mpoval=ipoval 185 : segdes mpoval 186 : segdes msoupo 187 : 410 continue 188 : segdes mchpoi 188 : call ecrobj ('CHPOINT',mchpo1) 189 : return 190 : end 191 : 192 : 193 : 194 : 195 : 196 : 197 : 198 : 199 : 200 : 201 : 202 : 203 : 204 : 205 :
© Cast3M 2003 - All rights reserved.
Disclaimer