1 : C YLAP22 SOURCE MAGN 09/07/30 21:22:26 6458 2 : C YLAP11 SOURCE LEPOTIER 03/02/13 21:24:03 4578 3 : SUBROUTINE YLAP22() 4 : C************************************************************************ 5 : C 6 : C PROJET : CASTEM 2000 7 : C 8 : C NOM : YLAPL11 9 : C 10 : C DESCRIPTION : Voir YLAPL1 11 : C 12 : C 13 : C LANGAGE : FORTRAN 77 + ESOPE 2000 (avec estensions CISI) 14 : C 15 : C AUTEUR : A. BECCANTINI, DRN/DMT/SEMT/LTMF 16 : C 17 : C************************************************************************ 18 : C 19 : C 20 : C APPELES (E/S) : LIRMOT, ERREUR 21 : C 22 : C 23 : C APPELES : YLAPL12 24 : C 25 : C************************************************************************ 26 : C 27 : C*** ENTREE / SORTIE (voir Phrase d'appel GIBIANE) 28 : C 29 : C*********************************************************************** 30 : C 31 : C HISTORIQUE (Anomalies et modifications éventuelles) 32 : C 33 : C HISTORIQUE : 11/02/2003 Ajout de l'option MIXT pour la température 34 : C 35 : C************************************************************************ 36 : C 37 : IMPLICIT INTEGER(I-N) 38 : -INC CCOPTIO 39 : -INC SMMATRIK 40 : -INC SMCHPOI 41 : -INC SMLMOTS 42 : POINTEUR MLMNOM.MLMOTS 43 : POINTEUR MLDEFO.MLMOTS 44 : -INC SMCHAML 45 : POINTEUR ICOGRV.MCHELM 46 : POINTEUR ICOGRT.MCHELM 47 : C 48 : C**** Variables de COOPTIO 49 : C 50 : C INTEGER IPLLB, IERPER, IERMAX, IERR, INTERR 51 : C & ,IOTER, IOLEC, IOIMP, IOCAR, IOACQ 52 : C & ,IOPER, IOSGB, IOGRA, IOSAU, IORES 53 : C & ,IECHO, IIMPI, IOSPI 54 : C & ,IDIM 55 : C & ,MCOORD 56 : C & ,IFOMOD, NIFOUR, IFOUR, NSDPGE, IONIVE 57 : C & ,NGMAXY, IZROSF, ISOTYP, IOSCR,LTEXLU 58 : C & ,NORINC,NORVAL,NORIND,NORVAD 59 : C & ,NUCROU, IPSAUV 60 : C 61 : C**** Variables de SMLMOTS 62 : C 63 : INTEGER JGM, JGN 64 : C 65 : C**** Variables de SMMATRIK 66 : C 67 : INTEGER NKID, NKMT, NMATRI, NRIGE 68 : C 69 : C**** Variables du programme 70 : C 71 : INTEGER ICELL, IRET, INDIC, NBCOMP 72 : & , IDOMA, MELEMC, MELEMF, MELEFL, ICHPSU, ICHPDI, ICHPVO 73 : & , INORM 74 : & , IRN, IVN, ITN, IGRVN, IGRTN 75 : & , IVNIMP, ITAUIM, ITIMP,IQIMP,IMIXT 76 : & , ILIINC, NC, INEFMD, ICOND 77 : & , IJACO, ICHFLU, ICHRES, NSOUPO,ICLAU 78 : REAL*8 MU,KAPPA,CV,DELTAT,XKT 79 : CHARACTER*(40) MESERR 80 : CHARACTER*4 MOT,LFLUX(2), LIMPL(2) 81 : CHARACTER*8 MOT2 82 : CHARACTER*8 TYPE 83 : LOGICAL LOGRES,LOGIMP,LOGAN 84 : C 85 : DATA LFLUX/'FLUX','RESI'/ 86 : DATA LIMPL/'EXPL','IMPL'/ 87 : C 88 : C**** Initialisation des variables pour la gestion des erreurs. 89 : C 90 : MESERR = ' ' 91 : LOGAN = .FALSE. 92 : LOGRES =.TRUE. 93 : C 94 : C******* Flux ou residu? 95 : C 96 : C 96 : CALL LIRMOT(LIMPL,2,ICELL,1) 97 : IF(IERR .NE. 0)GOTO 9999 98 : IF(ICELL .EQ. 1)THEN 99 : LOGIMP=.FALSE. 100 : ELSEIF(ICELL .EQ. 2)THEN 101 : LOGIMP=.TRUE. 102 : ELSE 103 : WRITE(IOIMP,*) 'Erreur de programmation' 103 : CALL ERREUR(5) 104 : GOTO 9999 105 : ENDIF 106 : 107 : 108 : C 109 : C********************************** 110 : C**** Lecture de l'objet MODELE *** 111 : C********************************** 112 : C 112 : c CALL GIBTEM(XKT) 113 : c WRITE(6,*) 'XKT1=',XKT 114 : ICOND = 1 114 : CALL QUETYP(TYPE,ICOND,IRET) 115 : 116 : IF(IRET.EQ.0.AND.TYPE.NE.'MMODEL')THEN 117 : WRITE(6,*)' On attend un objet MMODEL' 118 : RETURN 119 : ENDIF 119 : CALL LIROBJ('MMODEL',MMODEL,ICOND,IRET) 120 : IF(IERR.NE.0)GOTO 9999 120 : CALL LEKMOD(MMODEL,IDOMA,INEFMD) 121 : IF(IERR.NE.0)GOTO 9999 121 : c CALL GIBTEM(XKT) 122 : c WRITE(6,*) 'XKT2=',XKT 123 : C 124 : C**** Centre, FACE et FACEL 125 : C 125 : CALL LEKTAB(IDOMA,'CENTRE',MELEMC) 125 : c CALL GIBTEM(XKT) 126 : c WRITE(6,*) 'XKT3=',XKT 127 : IF(IERR .NE. 0) GOTO 9999 128 : C 128 : CALL LEKTAB(IDOMA,'FACE',MELEMF) 128 : c CALL GIBTEM(XKT) 129 : c WRITE(6,*) 'XKT4=',XKT 130 : IF(IERR .NE. 0) GOTO 9999 131 : C 131 : CALL LEKTAB(IDOMA,'FACEL',MELEFL) 131 : c CALL GIBTEM(XKT) 132 : c WRITE(6,*) 'XKT5=',XKT 133 : IF(IERR .NE. 0) GOTO 9999 134 : C 135 : C**** Lecture du CHPOINT contenant les surfaces des faces. 136 : C 136 : CALL LEKTAB(IDOMA,'XXSURFAC',ICHPSU) 136 : c CALL GIBTEM(XKT) 137 : c WRITE(6,*) 'XKT6=',XKT 138 : IF(IERR .NE. 0) GOTO 9999 139 : C 140 : C**** Lecture du CHPOINT contenant les diametres minimums. 141 : C 141 : CALL LEKTAB(IDOMA,'XXDIEMIN',ICHPDI) 141 : c CALL GIBTEM(XKT) 142 : c WRITE(6,*) 'XKT7=',XKT 143 : IF(IERR .NE. 0) GOTO 9999 144 : C 145 : C**** Lecture du CHPOINT contenant les volumes 146 : C 146 : CALL LEKTAB(IDOMA,'XXVOLUM',ICHPVO) 146 : c CALL GIBTEM(XKT) 147 : c WRITE(6,*) 'XKT8=',XKT 148 : IF(IERR .NE. 0) GOTO 9999 149 : C 150 : C********** Les normales aux faces 151 : C 151 : CALL LEKTAB(IDOMA,'XXNORMAF',INORM) 152 : IF(IERR .NE. 0) GOTO 9999 153 : 154 : C 155 : C 156 : C 157 : C 158 : C**** Température 159 : C 160 : TYPE='CHPOINT ' 160 : CALL LIROBJ(TYPE,ITN,1,IRET) 161 : IF(IERR .NE. 0) GOTO 9999 162 : JGN = 4 163 : JGM = 1 164 : SEGINI MLMNOM 165 : MLMNOM.MOTS(1) = 'SCAL' 165 : CALL QUEPO1(ITN, MELEMC, MLMNOM) 166 : IF(IERR .NE. 0) GOTO 9999 167 : SEGSUP MLMNOM 168 : C 169 : C 170 : C 171 : C**** Gradient de la temperature 172 : C 173 : TYPE='CHPOINT ' 173 : CALL LIROBJ(TYPE,IGRTN,1,IRET) 174 : IF(IERR .NE. 0) GOTO 9999 175 : JGN = 4 176 : JGM=1 177 : SEGINI MLMNOM 178 : MLMNOM.MOTS(1) = 'FLUX' 178 : CALL QUEPO1(IGRTN, MELEMF, MLMNOM) 179 : IF(IERR .NE. 0) GOTO 9999 180 : SEGSUP MLMNOM 181 : 182 : C 183 : IF (LOGIMP) THEN 183 : CALL LIROBJ('MCHAML ',ICOGRT,1,IRET) 184 : IF(IERR .NE. 0) GOTO 9999 185 : ENDIF 186 : 186 : CALL LIRCHA(MOT,0,IRET) 187 : IF(IRET .NE. 0)THEN 188 : IF(MOT .EQ. 'QIMP')THEN 189 : TYPE='CHPOINT ' 189 : CALL LIROBJ(TYPE,IQIMP,1,IRET) 190 : IF(IERR .NE. 0) GOTO 9999 191 : MCHPOI = IQIMP 192 : SEGACT MCHPOI 193 : NSOUPO = MCHPOI.IPCHP(/1) 194 : SEGDES MCHPOI 195 : IF(NSOUPO .GT.0)THEN 196 : JGN = 4 197 : JGM =1 198 : SEGINI MLMNOM 199 : MLMNOM.MOTS(1) = 'FLUX' 199 : CALL QUEPO1(IQIMP, 0, MLMNOM) 200 : IF(IERR .NE. 0) GOTO 9999 201 : SEGSUP MLMNOM 202 : ELSE 203 : IQIMP=0 204 : ENDIF 205 : ELSE 206 : IQIMP=0 207 : C********** Je m'excuse et je le remets dans la pile 208 : C 208 : CALL REFUS 209 : ENDIF 210 : ELSE 211 : IQIMP=0 212 : ENDIF 213 : 214 : C 215 : C Conditions aux limites mixtes 216 : C 216 : CALL LIRCHA(MOT,0,IRET) 217 : IF(IRET .NE. 0)THEN 218 : IF(MOT .EQ. 'MIXT')THEN 219 : TYPE='CHPOINT ' 219 : CALL LIROBJ(TYPE,IMIXT,1,IRET) 220 : IF(IERR .NE. 0) GOTO 9999 221 : MCHPOI = IMIXT 222 : SEGACT MCHPOI 223 : NSOUPO = MCHPOI.IPCHP(/1) 224 : SEGDES MCHPOI 225 : IF(NSOUPO .GT.0)THEN 226 : ELSE 227 : IMIXT=0 228 : ENDIF 229 : ELSE 230 : IMIXT=0 231 : C 232 : C********** Je m'excuse et je le remets dans la pile 233 : C 233 : CALL REFUS 234 : ENDIF 235 : ELSE 236 : IMIXT=0 237 : ENDIF 238 : C 239 : C Température imposée 240 : C 240 : CALL LIRCHA(MOT,0,IRET) 241 : IF(IRET .NE. 0)THEN 242 : IF(MOT .EQ. 'TIMP')THEN 243 : TYPE='CHPOINT ' 243 : CALL LIROBJ(TYPE,ITIMP,1,IRET) 244 : IF(IERR .NE. 0) GOTO 9999 245 : MCHPOI = ITIMP 246 : SEGACT MCHPOI 247 : NSOUPO = MCHPOI.IPCHP(/1) 248 : SEGDES MCHPOI 249 : IF(NSOUPO .GT.0)THEN 250 : JGN = 4 251 : JGM = 1 252 : SEGINI MLMNOM 253 : MLMNOM.MOTS(1) = 'SCAL' 253 : CALL QUEPO1(ITIMP, 0, MLMNOM) 254 : IF(IERR .NE. 0) GOTO 9999 255 : SEGSUP MLMNOM 256 : ELSE 257 : ITIMP=0 258 : ENDIF 259 : ELSE 260 : ITIMP=0 261 : C 262 : C********** Je m'excuse et je le remets dans la pile 263 : C 263 : CALL REFUS 264 : ENDIF 265 : ELSE 266 : ITIMP=0 267 : ENDIF 268 : C 269 : C 270 : C 271 : C Test des données 272 : C 273 : IF (.NOT.LOGIMP.AND.(ITIMP.NE.0)) THEN 274 : C**** La temperature imposéé à la paroi ne serve pas dans le 275 : C cas de proprietés physiques constantes en explicite 276 : MESERR='TIMP = ??? ' 277 : WRITE(IOIMP,*) MESERR 278 : C********** Message d'erreur standard 279 : C 21 2 280 : C Données incompatibles 281 : C 281 : CALL ERREUR(21) 282 : GOTO 9999 283 : ENDIF 284 : C 284 : c CALL GIBTEM(XKT) 285 : c WRITE(6,*) 'XKT1=',XKT 286 : IF (LOGIMP) THEN 287 : c IF (IDIM.EQ.2) THEN 287 : CALL YLAP1T(ITN,ICOGRT, 288 : $ ITIMP,IQIMP,IMIXT, 289 : $ MELEMC,MELEMF,MELEFL,ICHPSU,INORM,ICHPVO,IJACO) 290 : c ELSEIF (IDIM.EQ.3) THEN 290 : c CALL YLAP2T(MU,KAPPA,CV,IRN,IVN,ITN, 291 : c $ IGRVN,ICOGRV,ICOGRT, 292 : c $ IVNIMP,ITAUIM,ITIMP,IQIMP,IMIXT, 293 : c $ MELEMC,MELEMF,MELEFL,ICHPSU,INORM,ICHPVO,MLMOTS, 294 : c $ IJACO) 295 : c ELSE 296 : c WRITE(IOIMP,*) 'IDIM=',IDIM,' ILLICITE.' 296 : c CALL ERREUR(5) 297 : c GOTO 9999 298 : c ENDIF 299 : 300 : ELSE 301 : C 302 : C******* Objet MATRIK vide en explicite 303 : C 304 : NRIGE=7 305 : NMATRI=0 306 : NKID =9 307 : NKMT =7 308 : SEGINI MATRIK 309 : SEGDES MATRIK 310 : IJACO = MATRIK 311 : ENDIF 312 : C 313 : C**** Creation des flux aux interfaces 314 : C 315 : JGN=4 316 : JGM=1 317 : SEGINI MLDEFO 318 : DO ICELL=1,1,1 319 : MLDEFO.MOTS(ICELL)='RETN' 320 : ENDDO 321 : TYPE = 'CHPOINT ' 321 : CALL KRCHP1(TYPE, MELEMF, ICHFLU, MLDEFO) 321 : CALL GIBTEM(XKT) 322 : C 323 : C**** Calcul des flux et du pas du temps. 324 : C 325 : c IF(IDIM.EQ.2)THEN 325 : CALL YLA12T(IGRTN,IQIMP,MELEMC,MELEMF,MELEFL, 326 : & ICHPSU,INORM,ICHPDI,ICHFLU,DELTAT) 326 : CALL GIBTEM(XKT) 327 : c ELSE 327 : c CALL YLAP13T(MU,KAPPA,CV,IRN,IVN,IGRVN,IGRTN, 328 : c & IVNIMP,ITAUIM,IQIMP, 329 : c & MELEMC,MELEMF,MELEFL,ICHPSU,INORM,ICHPDI,ICHFLU,DELTAT) 330 : c ENDIF 331 : IF(IERR .NE. 0)GOTO 9999 332 : C 333 : C**** Calcul de residu (si LOGRES = .TRUE.) 334 : C 335 : IF(LOGRES)THEN 336 : TYPE = 'CHPOINT ' 336 : CALL KRCHP1(TYPE, MELEMC, ICHRES, MLDEFO) 337 : IF(IERR.NE.0) GOTO 9999 338 : C 338 : c CALL GIBTEM(XKT) 339 : c WRITE(6,*) 'XKT3=',XKT 339 : CALL KONRE1(MELEMC,MELEMF,MELEFL,ICHPVO, 340 : & ICHFLU, ICHRES, 341 : & LOGAN,MESERR) 342 : IF(LOGAN)THEN 343 : C 344 : C******* Anomalie detectée 345 : C 346 : C 347 : C******* Message d'erreur standard 348 : C -301 0 349 : C %m1:40 350 : C 351 : MOTERR(1:40) = MESERR(1:40) 352 : WRITE(IOIMP,*) MOTERR(1:40) 353 : C 354 : C******* Message d'erreur standard 355 : C 5 3 356 : C Erreur anormale.contactez votre support 357 : C 357 : CALL ERREUR(5) 358 : GOTO 9999 359 : ENDIF 360 : ELSE 361 : SEGSUP MLDEFO 362 : ICHRES = 0 363 : ENDIF 364 : 365 : C 366 : C**** Sortie 367 : C 367 : CALL ECRREE(DELTAT) 368 : TYPE = 'CHPOINT ' 368 : IF(ICHRES .NE. 0) CALL ECROBJ(TYPE,ICHRES) 368 : IF(ICHFLU .NE. 0) CALL ECROBJ(TYPE,ICHFLU) 369 : TYPE='MATRIK ' 369 : CALL ECROBJ(TYPE,IJACO) 370 : C 371 : 9999 RETURN 372 : END 373 : 374 : 375 : 376 : 377 : 378 : 379 : 380 : 381 : 382 : 383 : 384 :
© Cast3M 2003 - All rights reserved.
Disclaimer