1 : C PRE11 SOURCE CHAT 06/08/24 21:58:40 5529 2 : SUBROUTINE PRE11() 3 : C************************************************************************ 4 : C 5 : C PROJET : CASTEM 2000 6 : C 7 : C NOM : PRE11 8 : C 9 : C DESCRIPTION : Voir PRE1 10 : C 11 : C Cas gaz parfait monoespece 12 : C 13 : C 1er ordre en espace, 1er ordre en temps 14 : C 15 : C Creations des object MCHAML IROF, IVITF, IPF, 16 : C IGAMF 17 : C 18 : C LANGAGE : FORTRAN 77 + ESOPE 2000 (avec extensions CISI) 19 : C 20 : C AUTEUR : A. BECCANTINI, DRN/DMT/SEMT/TTMF 21 : C 22 : C************************************************************************ 23 : C 24 : C 25 : C APPELES (Outils) : LIRTAB, ACMO, LEKTAB, QUETYP, ERREUR, LIROBJ, 26 : C QUEPOI, ECROBJ 27 : C 28 : C APPELES (Calcul) : PRE111 (2D) 29 : C 30 : C 31 : C************************************************************************ 32 : C 33 : C HISTORIQUE (Anomalies et modifications éventuelles) 34 : C 35 : C HISTORIQUE : Créée le 11.6.98. 36 : C 37 : C************************************************************************ 38 : C 39 : C 40 : C**** Variables de COOPTIO 41 : C 42 : C INTEGER IPLLB, IERPER, IERMAX, IERR, INTERR 43 : C & ,IOTER, IOLEC, IOIMP, IOCAR, IOACQ 44 : C & ,IOPER, IOSGB, IOGRA, IOSAU, IORES 45 : C & ,IECHO, IIMPI, IOSPI 46 : C & ,IDIM 47 : C & ,MCOORD 48 : C & ,IFOMOD, NIFOUR, IFOUR, NSDPGE, IONIVE 49 : C & ,NGMAXY, IZROSF, ISOTYP, IOSCR,LTEXLU 50 : C & ,NORINC,NORVAL,NORIND,NORVAD 51 : C & ,NUCROU, IPSAUV, IFICLE, IPREFI 52 : C 53 : C**** Les variables 54 : C 55 : IMPLICIT INTEGER(I-N) 56 : INTEGER ICOND, IRETOU, IERR0, INDIC, NBCOMP 57 : & ,IDOMA, ICEN, IFACE, IFACEL, INORM, IROC, IVITC, IPC 58 : & ,IGAMC, IROF, IVITF, IPF, IGAMF, JGN, JGM, INEFMD 59 : & ,MMODEL 60 : REAL*8 VALER, VAL1, VAL2 61 : CHARACTER*(4) NOMTOT(3) 62 : CHARACTER*(8) MTYPR, TYPE 63 : CHARACTER*(40) MESERR 64 : LOGICAL LOGAN,LOGNEG, LOGBOR 65 : C 66 : C**** Les Includes 67 : C 68 : -INC CCOPTIO 69 : -INC SMLMOTS 70 : POINTEUR MLMVIT.MLMOTS 71 : C**** Initialisation des parametres d'erreur 72 : C 73 : LOGAN = .FALSE. 74 : LOGNEG = .FALSE. 75 : LOGBOR = .FALSE. 76 : MESERR = ' ' 77 : MOTERR(1:40) = MESERR(1:40) 78 : VALER = 0.0D0 79 : VAL1 = 0.0D0 80 : VAL2 = 0.0D0 81 : C 82 : C**** Initialisation des NOMTOT 83 : C 84 : NOMTOT(1) = ' ' 85 : NOMTOT(2) = ' ' 86 : NOMTOT(3) = ' ' 87 : C 88 : C**** Lecture de l'objet MODELE 89 : C 90 : ICOND = 1 90 : CALL QUETYP(TYPE,ICOND,IRETOU) 91 : 92 : IF(IRETOU.EQ.0.AND.TYPE.NE.'MMODEL')THEN 93 : WRITE(6,*)' On attend un objet MMODEL' 94 : RETURN 95 : ENDIF 95 : CALL LIROBJ('MMODEL',MMODEL,ICOND,IRETOU) 96 : IF(IERR.NE.0)GOTO 9999 96 : CALL LEKMOD(MMODEL,IDOMA,INEFMD) 97 : IF(IERR.NE.0)GOTO 9999 98 : C 99 : C**** Lecture du MELEME SPG des points CENTRE. 100 : C 101 : C 101 : C CALL LEKTAB(IDOMA,'CENTRE',IP) 102 : C 103 : C**** Probleme du LEKTAB: si IDOMA.'CENTRE' n'existe pas, 104 : C il crèe IDOMA.'CENTRE' sans recrèer 'FACEL' 105 : C -> la correspondance global des noeuds saut! 106 : C 107 : C On peut utilizer ACCTAB ou ACMO 108 : C 109 : MTYPR = 'MAILLAGE' 109 : CALL ACMO(IDOMA,'CENTRE',MTYPR,ICEN) 110 : IF(IERR.NE.0)GOTO 9999 111 : C 112 : C**** Lecture du MELEME 'FACE' 113 : C 114 : MTYPR = 'MAILLAGE' 114 : CALL ACMO(IDOMA,'FACE',MTYPR,IFACE) 115 : IF(IERR.NE.0)GOTO 9999 116 : C 117 : C**** Lecture du MELEME 'FACEL' 118 : C 119 : MTYPR = 'MAILLAGE' 119 : CALL ACMO(IDOMA,'FACEL',MTYPR,IFACEL) 120 : IF(IERR.NE.0)GOTO 9999 121 : C 122 : C**** Lecture du CHPOINT contenant les normales aux faces 123 : C 124 : IF(IDIM .EQ. 2)THEN 125 : C Que les normales 125 : CALL LEKTAB(IDOMA,'XXNORMAF',INORM) 126 : IF(IERR .NE. 0) GOTO 9999 127 : JGN = 4 128 : JGM = 2 129 : SEGINI MLMVIT 130 : MLMVIT.MOTS(1) = 'UX ' 131 : MLMVIT.MOTS(2) = 'UY ' 131 : CALL QUEPO1(INORM, IFACE, MLMVIT) 132 : SEGSUP MLMVIT 133 : IF(IERR.NE.0)GOTO 9999 134 : ELSE 135 : C Les normales et les tangentes 136 : MTYPR = ' ' 136 : CALL ACMO(IDOMA,'MATROT',MTYPR,INORM) 137 : IF (MTYPR .NE. 'CHPOINT ') THEN 137 : CALL MATRAN(IDOMA,INORM) 138 : IF(IERR .NE. 0) GOTO 9999 139 : ENDIF 140 : JGN = 4 141 : JGM = 9 142 : SEGINI MLMVIT 143 : MLMVIT.MOTS(1) = 'UX ' 144 : MLMVIT.MOTS(2) = 'UY ' 145 : MLMVIT.MOTS(3) = 'UZ ' 146 : MLMVIT.MOTS(4) = 'RX ' 147 : MLMVIT.MOTS(5) = 'RY ' 148 : MLMVIT.MOTS(6) = 'RZ ' 149 : MLMVIT.MOTS(7) = 'MX ' 150 : MLMVIT.MOTS(8) = 'MY ' 151 : MLMVIT.MOTS(9) = 'MZ ' 151 : CALL QUEPO1(INORM, IFACE, MLMVIT) 152 : SEGSUP MLMVIT 153 : IF(IERR.NE.0)GOTO 9999 154 : ENDIF 155 : C 156 : C**** Lecture du CHPOINT ROC 157 : C 158 : ICOND = 1 158 : CALL QUETYP(MTYPR,ICOND,IRETOU) 159 : IF(IERR .NE. 0)GOTO 9999 160 : IF(MTYPR .NE. 'CHPOINT ')THEN 161 : C 162 : C******* Message d'erreur standard 163 : C 37 2 164 : C On ne trouve pas d'objet de type %m1:8 165 : C 166 : MOTERR(1:8) = 'CHPOINT ' 166 : CALL ERREUR(37) 167 : GOTO 9999 168 : ELSE 169 : ICOND = 1 169 : CALL LIROBJ(MTYPR,IROC,ICOND,IRETOU) 170 : IF (IERR.NE.0) GOTO 9999 171 : ENDIF 172 : C 173 : C**** Control du CHPOINT: QUEPOI 174 : C 175 : C INDIC = 1 -> on impose le pointeur du support geometrique (IM1) 176 : C INDIC = 0 -> on ne fait que verifier le support geometrique (IM1) 177 : C 178 : C NBCOMP > 0 -> numero des composantes 179 : C 180 : C NOMTOT(1) = ' ' obligatoire s'on connais pas les noms des composantes 181 : C 182 : INDIC = 1 183 : NBCOMP = 1 184 : NOMTOT(1) = 'SCAL' 184 : CALL QUEPOI(IROC, ICEN, INDIC, NBCOMP, NOMTOT) 185 : IF(IERR .NE. 0)THEN 186 : IERR0 = IERR 187 : 188 : C 189 : C******* Message d'erreur standard 190 : C -301 0 %m1:40 191 : C 192 : MOTERR(1:40) = 'CHPO1 = ??? ' 193 : WRITE(IOIMP,*) MOTERR 194 : 195 : GOTO 9999 196 : ENDIF 197 : C 198 : C**** Lecture du CHPOINT VITC 199 : C 200 : ICOND = 1 200 : CALL QUETYP(MTYPR,ICOND,IRETOU) 201 : IF(IERR .NE. 0)GOTO 9999 202 : IF(MTYPR .NE. 'CHPOINT ')THEN 203 : C 204 : C******* Message d'erreur standard 205 : C 37 2 206 : C On ne trouve pas d'objet de type %m1:8 207 : C 208 : MOTERR(1:8) = 'CHPOINT ' 208 : CALL ERREUR(37) 209 : GOTO 9999 210 : ELSE 211 : ICOND = 1 211 : CALL LIROBJ('CHPOINT',IVITC,ICOND,IRETOU) 212 : IF (IERR.NE.0) GOTO 9999 213 : ENDIF 214 : C 215 : C**** Control du CHPOINT 216 : C 217 : JGN = 4 218 : JGM = IDIM 219 : SEGINI MLMVIT 220 : MLMVIT.MOTS(1) = 'UX ' 221 : MLMVIT.MOTS(2) = 'UY ' 222 : IF(IDIM .EQ. 3) MLMVIT.MOTS(3) = 'UZ ' 222 : CALL QUEPO1(IVITC, ICEN, MLMVIT) 223 : SEGSUP MLMVIT 224 : IF(IERR .NE. 0)THEN 225 : IERR0 = IERR 226 : 227 : C 228 : C******* Message d'erreur standard 229 : C -301 0 %m1:40 230 : C 231 : MOTERR(1:40) = 'CHPO2 = ??? ' 232 : WRITE(IOIMP,*) MOTERR 233 : 234 : GOTO 9999 235 : ENDIF 236 : C 237 : C**** Lecture du CHPOINT PC 238 : C 239 : ICOND = 1 239 : CALL QUETYP(MTYPR,ICOND,IRETOU) 240 : IF(IERR .NE. 0)GOTO 9999 241 : IF(MTYPR .NE. 'CHPOINT ')THEN 242 : C 243 : C******* Message d'erreur standard 244 : C 37 2 245 : C On ne trouve pas d'objet de type %m1:8 246 : C 247 : MOTERR(1:8) = 'CHPOINT ' 247 : CALL ERREUR(37) 248 : GOTO 9999 249 : ELSE 250 : ICOND = 1 250 : CALL LIROBJ('CHPOINT',IPC,ICOND,IRETOU) 251 : IF (IERR.NE.0) GOTO 9999 252 : ENDIF 253 : C 254 : C**** Control du CHPOINT 255 : C 256 : INDIC = 1 257 : NBCOMP = 1 258 : NOMTOT(1) = 'SCAL' 258 : CALL QUEPOI(IPC, ICEN, INDIC, NBCOMP, NOMTOT) 259 : IF(IERR .NE. 0)THEN 260 : IERR0 = IERR 261 : 262 : C 263 : C******* Message d'erreur standard 264 : C -301 0 %m1:40 265 : C 266 : MOTERR(1:40) = 'CHPO3 = ??? ' 267 : WRITE(IOIMP,*) MOTERR 268 : 269 : GOTO 9999 270 : ENDIF 271 : C 272 : C**** Lecture du CHPOINT GAMC 273 : C 274 : ICOND = 1 274 : CALL QUETYP(MTYPR,ICOND,IRETOU) 275 : IF(IERR .NE. 0)GOTO 9999 276 : IF(MTYPR .NE. 'CHPOINT ')THEN 277 : C 278 : C******* Message d'erreur standard 279 : C 37 2 280 : C On ne trouve pas d'objet de type %m1:8 281 : C 282 : MOTERR(1:8) = 'CHPOINT ' 282 : CALL ERREUR(37) 283 : GOTO 9999 284 : ELSE 285 : ICOND = 1 285 : CALL LIROBJ('CHPOINT',IGAMC,ICOND,IRETOU) 286 : IF (IERR.NE.0) GOTO 9999 287 : ENDIF 288 : C 289 : C**** Control du CHPOINT 290 : C 291 : INDIC = 1 292 : NBCOMP = 1 293 : NOMTOT(1) = 'SCAL' 293 : CALL QUEPOI(IGAMC, ICEN, INDIC, NBCOMP, NOMTOT) 294 : IF(IERR .NE. 0)THEN 295 : IERR0 = IERR 296 : 297 : C 298 : C******* Message d'erreur standard 299 : C -301 0 %m1:40 300 : C 301 : MOTERR(1:40) = 'CHPO4 = ??? ' 302 : WRITE(IOIMP,*) MOTERR 303 : 304 : GOTO 9999 305 : ENDIF 306 : C 307 : C**** Centre -> Face 308 : C 309 : IF(IDIM .EQ. 2)THEN 310 : C 311 : C******* Deux Dimensions, Une Espece, 1er ordre en espace, 1er ordre en 312 : C temps 313 : C 313 : CALL PRE111(ICEN,IFACE,IFACEL,INORM,IROC,IVITC,IPC,IGAMC, 314 : & IROF,IVITF,IPF,IGAMF, 315 : & LOGAN,LOGNEG,LOGBOR,MESERR,VALER,VAL1,VAL2) 316 : ELSE 317 : C 318 : C******* Trois Dimensions, Une Espece, 1er ordre en espace, 1er ordre en 319 : C temps 320 : C 321 : C 321 : CALL PRE112(ICEN,IFACE,IFACEL,INORM,IROC,IVITC,IPC,IGAMC, 322 : & IROF,IVITF,IPF,IGAMF, 323 : & LOGAN,LOGNEG,LOGBOR,MESERR,VALER,VAL1,VAL2) 324 : ENDIF 325 : C 326 : C**** Messages d'erreur 327 : C 328 : IF(LOGAN)THEN 329 : C 330 : C******* Anomalie detectée 331 : C 332 : C 333 : C******* Message d'erreur standard 334 : C -301 0 335 : C %m1:40 336 : C 337 : MOTERR(1:40) = MESERR(1:40) 338 : WRITE(IOIMP,*) MOTERR 339 : C 340 : C******* Message d'erreur standard 341 : C 5 3 342 : C Erreur anormale.contactez votre support 343 : C 343 : CALL ERREUR(5) 344 : GOTO 9999 345 : C 346 : ELSEIF(LOGNEG)THEN 347 : C 348 : C******* Message d'erreur standard 349 : C 41 2 350 : C %m1:8 = %r1 inférieur à %r2 351 : C 352 : MOTERR(1:8) = MESERR(1:8) 353 : REAERR(1) = REAL(VALER) 354 : REAERR(2) = 0.0 354 : CALL ERREUR(41) 355 : GOTO 9999 356 : ELSEIF(LOGBOR)THEN 357 : C 358 : C******* Message d'erreur standard 359 : C 42 2 360 : C %m1:8 = %r1 non compris entre %r2 et %r3 361 : C 362 : MOTERR(1:8) = MESERR(1:8) 363 : REAERR(1) = REAL(VALER) 364 : REAERR(2) = REAL(VAL1) 365 : REAERR(3) = REAL(VAL2) 365 : CALL ERREUR(42) 366 : GOTO 9999 367 : ELSE 368 : C 369 : C******* Ecriture de ROF, VITF, PF 370 : C 371 : MTYPR = 'MCHAML' 371 : CALL ECROBJ(MTYPR,IGAMF) 371 : CALL ECROBJ(MTYPR,IPF) 371 : CALL ECROBJ(MTYPR,IVITF) 371 : CALL ECROBJ(MTYPR,IROF) 372 : ENDIF 373 : C 374 : 9999 CONTINUE 375 : C 376 : RETURN 377 : END 378 : 379 : 380 : 381 : 382 : 383 : 384 : 385 : 386 : 387 : 388 : 389 :
© Cast3M 2003 - All rights reserved.
Disclaimer