1 : C EVRECO SOURCE KICH 08/06/26 21:16:23 6133 2 : SUBROUTINE EVRECO(ICOUL) 3 : IMPLICIT INTEGER(I-N) 4 : IMPLICIT REAL*8(A-H,O-Z) 5 : C======================================================================= 6 : C OPTION RECO DE L'OPERATEUR EVOL 7 : C 8 : C.1.EVOLUTION D'UN DDL DANS L'OBJET SOLUTION: 9 : C MEVOL = EVOL COUL RECO MSOLUT BASE TYPE PT1 COMP (INSTANTS) ; 10 : C ---- ---- ---- ---- 11 : C 12 : C.2.EVOLUTION DE PLUSIEURS DDL DANS L'OBJET SOLUTION: 13 : C MEVOL = EVOL COUL RECO MSOLUT BASE TYPE CHP1 (INSTANTS) ; 14 : C.3.EVOLUTION DE PLUSIEURS DDL DANS L'OBJET TABLE 15 : C MEVOL = EVOL COUL RECO TRESU TBASE TYPE PT1 COMP (INSTANTS) ; 16 : C ---- ---- ---- ---- 17 : C 18 : C COUL : COULEUR DE LA (OU DES) COURBE(S) 19 : C MEVOL : OBJET DE TYPE EVOLUTION 20 : C MSOLUT : OBJET SOLUTION 21 : C TYPE : MOT CLE:TYPE DE LA VARIABLE (DEPL,VITE,ACCE,CONT..) 22 : C COMP : NOM DE LA COMPOSANTE CHOISIE 23 : C INSTANTS: PROCEDURE FACULTATIVE POUR CHOISIR LES CAS DE SORTIE 24 : C PROGX :OBJET LISTREEL, LISTE DES TEMPS A SORTIR 25 : C LECTC :OBJET LISTENTI, LISTE DES CAS A SORTIR 26 : C RIEN :L'OBJET EVOLUTION PORTE SUR TOUS LES CAS PRESENTS 27 : C DANS LE MSOLUT 28 : C 29 : C BASE : BASE ELEMENTAIRE 30 : C BASE STRU N 31 : C 32 : C PT1 : POINT OU MELEME A EXTRAIRE 33 : C CHP1 : CHPOINT CONTENANT LES POINTS ET DDL (FABRIQUE PAR 34 : C EXEMPLE PAR MANU CHPO ) 35 : C 36 : C LES OBJETS PT1,CHP1 SERVENT A REPERER DANS LES CHAMPS 37 : C CHOISIS, LE(S) POINT(S) QUI INTERESSENT L'EVOLUTION. 38 : C 39 : C CREATION : 16/10/85 40 : C PROGRAMMEUR : FARVACQUE 41 : C======================================================================= 42 : -INC CCOPTIO 43 : -INC SMSOLUT 44 : -INC SMTABLE 45 : -INC SMBASEM 46 : -INC SMEVOLL 47 : -INC SMELEME 48 : -INC SMLENTI 49 : -INC SMCHPOI 50 : LOGICAL L0,L1 51 : SEGMENT NUMOO 52 : INTEGER NUMO(N),KLIST(N) 53 : CHARACTER*4 NUDDL(N) 54 : ENDSEGMENT 55 : CHARACTER*4 TI1 56 : CHARACTER*8 ITYPE,ITYP1,CTYP,TYPRET,CHARRE 57 : CHARACTER*72 TI,MCHA,NOMCO 58 : C 59 : C======================================================================= 60 : ICONT=0 61 : KPSMO=0 62 : ISOLU=0 63 : ITABL=0 64 : * 65 : *---- type du prochain objet @ lire ( TABLE ou SOLUTION ) 66 : * 66 : CALL QUETYP (CTYP,1,IRETOU) 67 : IF (IERR.NE.0) RETURN 68 : * 69 : * --- on lit le nom du champ @ traiter et le nom de la composante 69 : CALL LIRCHA(MCHA,1,IRETOU) 70 : IF(IERR.NE.0) RETURN 71 : IF (MCHA.EQ.'CONT') ICONT = 1 72 : IF (MCHA.EQ.'REAC') ICONT = 2 73 : LCHALU=IRETOU 73 : CALL LIRCHA(NOMCO,0,IRETOU) 74 : IF(IRETOU.EQ.0) NOMCO=' ' 75 : * 76 : * --- on recup}re le point ou le maillage ou le chpoint 76 : CALL LIROBJ('POINT ',IRET,0,IRETOU) 77 : IF (IRETOU.EQ.0) THEN 77 : CALL LIROBJ('MAILLAGE',IRET,0,IRETOU) 78 : IF (IRETOU.EQ.0) THEN 78 : CALL LIROBJ('CHPOINT ',IRET,0,IRETOU) 79 : IF (IRETOU.EQ.0) THEN 80 : * on ne trouve pas le support qui contient les points 80 : CALL ERREUR(248) 81 : RETURN 82 : ELSE 83 : ITYPE='CHPOINT' 84 : ENDIF 85 : ELSE 86 : ITYPE='MAILLAGE' 87 : ENDIF 88 : ELSE 89 : ITYPE='POINT' 90 : ENDIF 91 : iptu = iret 92 : *-------------------------------------------- 93 : *---cas d'un objet de type TABLE ------------ 94 : *-------------------------------------------- 94 : call lirtab('PASAPAS',ITAP,0,iretou) 95 : if (iretou.gt.0) then 95 : call lirobj('MMODEL', IPMODE,1,iretou) 96 : if (ierr.ne.0) return 96 : CALL LIROBJ('MCHAML',IPCHA1,1,IRETOU) 97 : if (ierr.ne.0) return 97 : if (iretou.gt.0) call evrec6(itap,ipmode,ipcha1,mcha,nomco, 98 : &itype,iptu,ipevo) 99 : if (ierr.ne.0) return 99 : if (ipevo.gt.0) call ecrobj('EVOLUTION',ipevo) 100 : return 101 : endif 102 : 103 : IF (CTYP(1:5).EQ.'TABLE') THEN 104 : ITABL = 1 104 : CALL LIRTAB ('RESULTAT_DYNE',ISTA,1,IRETOU) 105 : IF (IERR.NE.0) RETURN 105 : CALL LIRTAB ('BASE_MODALE',ISBM,0,IRETOU) 106 : IF (IRETOU.EQ.0) THEN 106 : CALL LIRTAB ('ENSEMBLE_DE_BASES',ISEB,1,IRETOU) 107 : IF (IERR.NE.0) RETURN 108 : IT = 0 109 : 56 CONTINUE 110 : IT = IT + 1 111 : TYPRET = ' ' 111 : CALL ACCTAB (ISEB,'ENTIER',IT,X0,' ',L0,IRET0, 112 : & TYPRET,I1,X1,CHARRE,L1,ISBM) 113 : IF (ISBM.NE.0 .AND. TYPRET.EQ.'TABLE ') THEN 113 : CALL ACCTAB (ISBM,'MOT',I0,X0,'MODES',L0,IRET0, 114 : & 'TABLE',I1,X1,' ',L1,ISTB) 114 : CALL ACCTAB (ISTB,'MOT',I0,X0,'MAILLAGE',L0,IRET0, 115 : & 'MAILLAGE',I1,X1,' ',L1,IMAIL) 115 : CALL EXTR12(IMAIL,IRET,IRE12) 116 : IF (IRE12.EQ.0) GOTO 56 117 : TYPRET = ' ' 117 : CALL ACCTAB (ISBM,'MOT',I0,X0,'PSEUDO_MODES',L0,IRET0, 118 : & TYPRET,I1,X1,CHARRE,L1,ITPS) 119 : IF (ITPS.NE.0 .AND. TYPRET.EQ.'TABLE ') KPSMO = 1 120 : ELSE 121 : RETURN 122 : ENDIF 123 : ELSE 123 : CALL ACCTAB (ISBM,'MOT',I0,X0,'MODES',L0,IRET0, 124 : & 'TABLE',I1,X1,' ',L1,ISTB) 125 : TYPRET = ' ' 125 : CALL ACCTAB (ISBM,'MOT',I0,X0,'PSEUDO_MODES',L0,IRET0, 126 : & TYPRET,I1,X1,CHARRE,L1,ITPS) 127 : IF (ITPS.NE.0 .AND. TYPRET.EQ.'TABLE ') KPSMO = 1 128 : ENDIF 129 : ENDIF 130 : *-------------------------------------------- 131 : *---cas d'un objet de type solution --------- 132 : *-------------------------------------------- 133 : IF (CTYP(1:8).EQ.'SOLUTION') THEN 133 : CALL LIROBJ('SOLUTION',KSOLU,1,IRETOU) 134 : IF(IERR.NE.0) RETURN 135 : ISOLU = 1 136 : MSOLUT=KSOLU 137 : C---------------------------------------------------- 138 : C **** lecture de la base {l{mentaire 139 : C 139 : CALL LIRBAS(1,IBOBAS,IBOSEM) 140 : MSOBAS=IBOBAS 141 : MBASEM=IBOSEM 142 : IF(IERR.NE.0) RETURN 143 : ENDIF 144 : C---------------------------------------------------- 145 : C **** lecture du chargement pour les pseudo-modes 146 : C 147 : KCHAR = 0 147 : CALL LIROBJ('CHARGEME',KCHAR,0,IRETOU) 148 : C---------------------------------------------------- 149 : C **** lecture des instants 150 : C 151 : IPX=0 152 : ITOUS=0 153 : ILX=0 153 : CALL LIROBJ('LISTREEL',IPX,0,IRETOU) 153 : IF(IRETOU.EQ.0) CALL LIROBJ('LISTENTI',ILX,0,IRETOU) 154 : IF(IRETOU.EQ.0) ITOUS=1 155 : * 155 : CALL EVNUMO(ITYPE,IRET,NOMCO,IBOO) 156 : NUMOO=IBOO 157 : IF(IERR.NE.0) RETURN 158 : *+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+ 159 : * cas d'un objet de type SOLUTION 160 : *+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+ 161 : IF (ISOLU.EQ.1) THEN 162 : SEGACT MSOLUT 163 : IF (MCHA.EQ.'CONT') MCHA = 'DEPL' 164 : MOTERR(1:8)=ITYSOL 164 : CALL CHRCHA(MCHA,MOTERR(1:8),ICHA,ISOLIT) 165 : IF(ICHA.EQ.0) THEN 166 : MOTERR(1:8)=ITYSOL 167 : MOTERR(9:12)=MCHA 167 : CALL ERREUR(235) 168 : * erreur dans le type du champ 169 : RETURN 170 : ENDIF 171 : MSOLEN=MSOLIS(ICHA) 172 : IF(MSOLEN.EQ.0) THEN 173 : MOTERR(1:8)=ITYSOL 174 : MOTERR(9:12)=MCHA 174 : CALL ERREUR(235) 175 : * ce type de champ est vide dans le MSOLUT 176 : RETURN 177 : ENDIF 178 : IF (ITYSOL.NE.'DYNAMIQU') THEN 179 : MOTERR(1:8)='SOLUTION' 180 : MOTERR(9:16)=ITYSOL 180 : CALL ERREUR(131) 181 : * option non disponible 182 : RETURN 183 : ENDIF 184 : IF (MSOLIT(ICHA).NE.2) THEN 185 : * la sortie porte sur des CHAMELEM 186 : * option non disponible 186 : CALL ERREUR(19 ) 187 : RETURN 188 : ENDIF 189 : IBOS=MSOLUT 190 : * v{rification des instants de sortie 191 : * dans IPX le LISTREEL @ mettre dans IPROGX 192 : * dans ILEX le LISTENTI qui contient les num{ros des champs 192 : CALL VERIDY(IBOS,IPX,ICHA,ITOUS,ILEX,ITYP1) 193 : IF(IERR.NE.0) RETURN 194 : MSOLUT=IBOS 195 : * 196 : IBOBAS=MSOBAS 197 : IBOO=NUMOO 197 : CALL EVOL2(IBOO,ILEX,IBOBAS,ICONT) 198 : IF(IERR.NE.0) RETURN 199 : MSOBAS=IBOBAS 200 : NUMOO=IBOO 201 : MLENTI=ILEX 202 : SEGSUP MLENTI 203 : * 204 : * prise en compte des pseudo-modes 205 : * 206 : SEGACT MSOBAS 207 : IMODE = IBSTRM(2) 208 : ILIAI = IBSTRM(4) 209 : KPSMO = IBSTRM(5) 210 : SEGDES MSOBAS 211 : IF (KPSMO.NE.0) THEN 212 : IF (ILIAI.NE.0) THEN 213 : MSOLUT = KSOLU 214 : SEGACT MSOLUT 215 : MOTERR(1:8) = ITYSOL 216 : MCHA = 'LIAI' 216 : CALL CHRCHA(MCHA,MOTERR(1:8),ICHA,ISOLIT) 217 : IF (ICHA.EQ.0) THEN 218 : MOTERR(1:8) = ITYSOL 219 : MOTERR(9:12) = MCHA 219 : CALL ERREUR(235) 220 : RETURN 221 : ENDIF 222 : MSOLEN = MSOLIS(ICHA) 223 : IF (MSOLEN.EQ.0) THEN 224 : MOTERR(1:8) = ITYSOL 225 : MOTERR(9:12) = MCHA 225 : CALL ERREUR(235) 226 : RETURN 227 : ENDIF 228 : SEGDES MSOLUT 229 : ITOU2 = 0 230 : IBOS = KSOLU 230 : CALL VERIDY(IBOS,IPX,ICHA,ITOU2,ILEX2,ITYP1) 231 : IF (IERR.NE.0) RETURN 232 : ELSE 233 : ILEX2 = 0 234 : ENDIF 235 : IBOO = NUMOO 235 : CALL PSEVO1(IMODE,KPSMO,IBOO,IPX,ILEX2,KCHAR,ICONT) 236 : NUMOO = IBOO 237 : ENDIF 238 : ENDIF 239 : *+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+ 240 : * cas d'un objet de type TABLE 241 : *+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+ 242 : IF (ITABL.EQ.1) THEN 243 : ICHA =0 244 : LBO=0 245 : * on prend la premi}re table (pas de temps 1) 245 : CALL ACCTAB (ISTA ,'ENTIER',1,X0,' ',L0,IRET0, 246 : & 'TABLE',I1,X1,' ',L1,IRET1) 247 : IF (ICONT.EQ.1) MCHA = 'DEPL' 248 : IF (ICONT.EQ.2) MCHA = 'DEPL' 249 : IBOBO=IRET1 249 : CALL CHTCHA (MCHA,LCHALU,IBOBO,ICHA) 250 : IF (ICHA.EQ.0) THEN 251 : MOTERR(1:8)= MCHA(1:8) 252 : MOTERR(9:12)=MCHA 252 : CALL ERREUR(235) 253 : * erreur dans le type du champ 254 : RETURN 255 : ENDIF 256 : * v{rification des instants de sortie 257 : * dans IPX le LISTREEL @ mettre dans IPROGX 258 : * dans ILEX le LISTENTI qui contient les num{ros des champs 258 : CALL VERITA(ISTA,IPX,ICHA,ITOUS,ILEX,ITYP1) 259 : IF (IERR.NE.0) RETURN 260 : * 260 : CALL CHCHA2 (ISTB,ILEN1,ILEN2,ICONT) 261 : IF(IERR.NE.0) RETURN 262 : * 263 : IBOO=NUMOO 263 : CALL EVOL22 (IBOO,ILEX,ISTB,ILEN1,ILEN2) 264 : IF(IERR.NE.0) RETURN 265 : NUMOO=IBOO 266 : * 267 : * prise en compte de la rotation des corps rigides 268 : * 269 : IF (MCHA(1:4).EQ.'DEPL') THEN 270 : * On regarde si on a une base de corps rigide 270 : CALL VERRIG(ISTB,IROT,ICDG,ILEN1,ILEN2,IDEFO) 271 : IF (IROT.NE.0) THEN 272 : IBOO = NUMOO 273 : * Recombinaison des d�placements 273 : CALL EVORIG(IROT,ICDG,IBOO,ILEX,0,0,0,IDEFO) 274 : NUMOO = IBOO 275 : ENDIF 276 : ELSE 277 : IF (MCHA(1:4).EQ.'VITE') THEN 278 : * On regarde si on a une base de corps rigide 278 : CALL VERRIG(ISTB,IROT,ICDG,ILEN1,ILEN2,IDEFO) 279 : IF (IROT.NE.0) THEN 280 : * On r�cup�re les angles de rotation 280 : CALL CHTCHA('DEPL',4,IBOBO,ICHARO) 281 : IF (ICHARO.EQ.0) THEN 282 : MOTERR(1:8)=MCHA(1:8) 283 : MOTERR(9:12)=MCHA 283 : CALL ERREUR(235) 284 : RETURN 285 : ENDIF 285 : CALL VERITA(ISTA,IPX,ICHARO,ITOUS,ILEXRO,ITYP1) 286 : IBOO = NUMOO 287 : * On recombine les vitesses 287 : CALL EVORIG(IROT,ICDG,IBOO,ILEX,1,ILEXRO,0,IDEFO) 288 : NUMOO = IBOO 289 : ENDIF 290 : ELSE 291 : IF (MCHA(1:4).EQ.'ACCE') THEN 292 : * On regarde si on a une base de corps rigide 292 : CALL VERRIG(ISTB,IROT,ICDG,ILEN1,ILEN2,IDEFO) 293 : IF (IROT.NE.0) THEN 294 : * On r�cup�re les angles de rotation 294 : CALL CHTCHA('DEPL',4,IBOBO,ICHARO) 295 : IF (ICHARO.EQ.0) THEN 296 : MOTERR(1:8)=MCHA(1:8) 297 : MOTERR(9:12)=MCHA 297 : CALL ERREUR(235) 298 : RETURN 299 : ENDIF 299 : CALL VERITA(ISTA,IPX,ICHARO,ITOUS,ILEXRO,ITYP1) 300 : * On r�cup�re les vitesses de rotation 300 : CALL CHTCHA('VITE',4,IBOBO,ICHAVI) 301 : IF (ICHAVI.EQ.0) THEN 302 : MOTERR(1:8)=MCHA(1:8) 303 : MOTERR(9:12)=MCHA 303 : CALL ERREUR(235) 304 : RETURN 305 : ENDIF 305 : CALL VERITA(ISTA,IPX,ICHAVI,ITOUS,ILEXVI,ITYP1) 306 : IBOO = NUMOO 307 : * On recombine les acc�l�rations 307 : CALL EVORIG(IROT,ICDG,IBOO,ILEX,-1,ILEXRO, 308 : &ILEXVI,IDEFO) 309 : NUMOO = IBOO 310 : ENDIF 311 : ENDIF 312 : ENDIF 313 : ENDIF 314 : MLENTI=ILEN1 315 : SEGSUP MLENTI 316 : MLENTI=ILEN2 317 : SEGSUP MLENTI 318 : MLENTI=ILEX 319 : SEGSUP MLENTI 320 : * 321 : * prise en compte des pseudo-modes 322 : * 323 : IF (KPSMO.EQ.1) THEN 324 : IF (KCHAR.NE.0) THEN 325 : IBOO = NUMOO 325 : CALL PSEVRC(ICONT,ITPS,ISTB,IBOO,IPX,KCHAR) 326 : NUMOO = IBOO 327 : ELSE 327 : CALL ERREUR(430) 328 : ENDIF 329 : ENDIF 330 : ENDIF 331 : C ****************************************************************** 332 : C *** initialisation de MEVOLL 333 : C 334 : IF (ICONT.EQ.1) MCHA='CONT' 335 : IF (ICONT.EQ.2) MCHA='REAC' 336 : N=NUMO(/1) 337 : SEGINI MEVOLL 338 : ITYEVO='REEL' 339 : TI(1:72)=TITREE 340 : IEVTEX=TI 341 : DO 2080 I=1,N 342 : SEGINI KEVOLL 343 : TYPX='LISTREEL' 344 : TYPY='LISTREEL' 345 : IPROGX=IPX 346 : IPROGY=KLIST(I) 347 : NOMEVX=ITYP1 348 : NOMEVY(1:4)=MCHA 349 : WRITE (NOMEVY(5:8),FMT='(I4)') NUMO(I) 350 : NOMEVY(9:12)=NUDDL(I) 351 : KEVTEX=TI 352 : NUMEVY='REEL' 353 : NUMEVX=ICOUL 354 : SEGDES KEVOLL 355 : IEVOLL(I)=KEVOLL 356 : 2080 CONTINUE 357 : SEGDES MEVOLL 358 : SEGSUP NUMOO 358 : CALL ECROBJ('EVOLUTIO',MEVOLL) 359 : * 360 : END 361 : 362 : 363 : 364 :
© Cast3M 2003 - All rights reserved.
Disclaimer