1 : C EVTEMP SOURCE CHAT 11/05/27 21:15:16 6984 2 : subroutine EVTEMP(icoul) 3 : implicit integer(i-n) 4 : implicit real*8(a-h,o-z) 5 : -INC CCOPTIO 6 : -INC SMCHAML 7 : -INC SMCHPOI 8 : -INC SMTABLE 9 : -INC SMLREEL 10 : -INC SMEVOLL 11 : -INC SMELEME 12 : logical login 13 : character*8 typobj 14 : character*18 charin,chalu 15 : character*1 charre 16 : character*4 compo,noco 17 : character*8 nompoi 17 : call lirobj ('TABLE ',mtable,1,iretou) 18 : if(ierr.ne.0) return 19 : ilo=0 19 : call lircha(chalu,1,ilo) 20 : TYPOBJ='TABLE' 21 : charin='TEMPS' 22 : segact mtable 22 : call acctab(mtable,'MOT',ivalin,xvalin,charin(1:5),login,iobi, 23 : $ TYPOBJ,ivalin,xvalin,charre,login,mtab1) 24 : if( ierr.ne.0) return 25 : segact mtable 25 : call acctab(mtable,'MOT',ivalin,xvalin,chalu(1:ilo),login,iobi, 26 : $ TYPOBJ,ivalin,xvalin,charre,login,mtab2) 27 : if( ierr.ne.0) return 28 : compo=' ' 28 : call lircha (compo,0,ilp) 29 : segact mtab1,mtab2 30 : typobj=mtab2.mtabtv(1) 31 : if(typobj.eq.'CHPOINT ') then 31 : call lirobj('POINT' , IP1,1,iretou) 31 : call quenom(nompoi) 32 : if(ierr.ne.0) then 33 : moterr(1:8)='TABLE' 34 : segdes mtab1,mtab2 35 : return 36 : endif 37 : jg = mtab1.mlotab 38 : if(mtab2.mlotab.ne.jg) then 39 : segdes mtab1,mtab2 39 : call erreur ( 1015 ) 40 : return 41 : endif 42 : segini mlree1,mlree2 43 : do 10 ia=1,mtab1.mlotab 44 : 45 : mlree1.prog(ia)= mtab1.rmtabv(ia) 46 : mchpoi=mtab2.mtabiv(ia) 47 : segact mchpoi 48 : if( ipchp(/1).eq.0.and.ia.eq.1) then 49 : mlree2.prog(ia)=0. 50 : segdes mchpoi 51 : go to 10 52 : endif 53 : do 11 isou=1,ipchp(/1) 54 : msoupo= ipchp(isou) 55 : segact msoupo 56 : meleme=igeoc 57 : segact meleme 58 : noco=nocomp(1) 59 : icomp=1 60 : do 12 iel=1,num(/2) 61 : if(num(1,iel).eq.ip1) then 62 : if(ilp.eq.0.and.nocomp(/2).ne.1) then 63 : MOTERR(1:8)='chpoint' 64 : INTERR(1)=NOCOMP(/2) 64 : call erreur(761) 65 : segdes meleme,msoupo,mchpoi 66 : go to 100 67 : endif 68 : do 13 icomp=1,nocomp(/2) 69 : noco=nocomp(icomp) 70 : if(nocomp(icomp).eq.compo) goto 14 71 : 13 continue 72 : 73 : MOTERR(1:4)=COMPO 74 : moterr(5:12)='CHPOINT' 75 : interr(1)=ip1 75 : call erreur(65) 76 : segdes meleme,msoupo,mchpoi 77 : go to 100 78 : 14 continue 79 : mpoval=ipoval 80 : segact mpoval 81 : noco=nocomp(icomp) 82 : mlree2.prog(ia)=vpocha(iel,icomp) 83 : segdes mpoval 84 : segdes meleme 85 : segdes mchpoi 86 : segdes msoupo 87 : go to 10 88 : endif 89 : 12 continue 90 : segdes meleme 91 : segdes msoupo 92 : 11 continue 93 : interr(1)=ip1 94 : moterr(1:)='CHPOINT' 94 : call erreur(64) 95 : segdes mchpoi 96 : go to 100 97 : 10 continue 98 : 99 : segdes mlree1,mlree2 100 : N=1 101 : 102 : segini mevoll 103 : ityevo='REEL' 104 : IEVTEX=chalu(1:ilo)//' '//noco//' fonction du temps du point ' 105 : $ //nompoi 106 : segini kevoll 107 : ievoll(1)=kevoll 108 : iprogx=mlree1 109 : iprogy=mlree2 110 : numevx=icoul 111 : NUMEVY='REEL' 112 : NOMEVY=chalu(1:6) // ' '//noco 113 : NOMEVX='TEMPS' 114 : TYPX='LISTREEL' 115 : TYPY='LISTREEL' 116 : KEVTEX=chalu(1:ilo)//' fonction du temps du point '//nompoi 117 : 101 format (I6) 118 : segdes mevoll,kevoll 118 : call ecrobj('EVOLUTIO',mevoll) 119 : return 120 : elseif(typobj.eq.'MCHAML' )then 120 : call lirent ( izo,1,iretou) 121 : if(ierr.ne.0) return 121 : call lirent(iel,1,iretou) 122 : if(ierr.ne.0) return 122 : call lirent(iga,1,iretou) 123 : if(ierr.ne.0) return 124 : jg = mtab1.mlotab 125 : if(mtab2.mlotab.ne.jg) then 126 : segdes mtab1,mtab2 126 : call erreur ( 1015 ) 127 : go to 100 128 : endif 129 : segini mlree1,mlree2 130 : do 20 ia = 1, mtab2.mlotab 131 : mlree1.prog(ia)= mtab1.rmtabv(ia) 132 : mchelm=mtab2.mtabiv(ia) 133 : segact mchelm 134 : if( ichaml(/1).lt.izo) then 134 : call erreur(279) 135 : segdes mchelm 136 : go to 100 137 : endif 138 : mchaml=ichaml(izo) 139 : meleme=imache(izo) 140 : segact mchaml,meleme 141 : icomp=1 142 : if(ilp.eq.0.and.nocomp(/2).ne.1) then 143 : MOTERR(1:8)='MCHAML' 144 : INTERR(1)=NOMCHE(/2) 144 : call erreur(761) 145 : segdes mchaml,mchelm,meleme 146 : go to 100 147 : endif 148 : if(num(/2).lt.iel) then 148 : call erreur(262) 149 : segdes mchelm,mchaml,meleme 150 : go to 100 151 : endif 152 : noco=nomche(1) 153 : icomp=1 154 : do 23 icomp=1,nomche(/2) 155 : noco=nomche(icomp) 156 : if(noco.eq.compo) goto 24 157 : 23 continue 158 : MOTERR(1:4)=COMPO 159 : moterr(5:12)='MCHAML' 160 : interr(1)=ip1 160 : call erreur(65) 161 : segdes mchelm,mchaml,meleme 162 : go to 100 163 : 24 continue 164 : melval=ielval(icomp) 165 : segact melval 166 : mlree2.prog(ia)=velche(min(velche(/1),iga),min(velche(/2),iel)) 167 : segdes melval 168 : segdes mchaml,meleme 169 : segdes mchelm 170 : 20 continue 171 : endif 172 : N=1 173 : segini mevoll 174 : segini kevoll 175 : ityevo='REEL' 176 : if(typobj.eq.'CHPOINT ') then 177 : IEVTEX=chalu(1:ilo)//' '//noco//' fonction du temps du point ' 178 : $ //nompoi 179 : elseif(typobj.eq.'MCHAML') then 180 : IEVTEX=chalu(1:ilo)//' '//noco//' zone ' 181 : write(ievtex(ilo+12:ilo+36),102)izo,' elem ',iel,' gauss ',iga 182 : endif 183 : 102 format (I4,A6,i6,a7,i2) 184 : KEVTEX=IEVTEX 185 : ievoll(1)=kevoll 186 : iprogx=mlree1 187 : iprogy=mlree2 188 : numevx=icoul 189 : NUMEVY='REEL' 190 : NOMEVY=chalu(1:6) // ' '//noco 191 : NOMEVX='TEMPS' 192 : TYPX='LISTREEL' 193 : TYPY='LISTREEL' 194 : segdes mevoll,kevoll 194 : call ecrobj('EVOLUTIO',mevoll) 195 : return 196 : 100 continue 197 : segsup mlree1,mlree2 198 : return 199 : end 200 : 201 : 202 :
© Cast3M 2003 - All rights reserved.
Disclaimer