1 : C TRJFLU SOURCE PV 09/03/13 21:17:09 6328 2 : SUBROUTINE TRJFLU(IPTFL,ITR,MCHELM,IELTFA,MELEME,IZVIT) 3 : C 4 : IMPLICIT INTEGER(I-N) 5 : IMPLICIT REAL*8 (A-H,O-Z) 6 : CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 7 : C 8 : C MET LES FLUX SOUS UNE FORME AGREABLE POUR LE 9 : C CALCUL DES TRAJECTOIRES (FORMULATION HYBRIDE) 10 : C 11 : C ENTREES 12 : C IPTFL = MCHPOI1 POINTEUR DU CHPOINT DES FLUX PAR FACES 13 : C = MTABLE POINTEUR DE LA TABLE RESULTAT DU TRANSITOIRE 14 : C ITR = 3 TRANSITOIRE 15 : C MCHELM POINTEUR DU MCHAML CONTENANT L'ORIENTATION DU FLUX 16 : C IELTFA POINTEUR DU MAILLAGE FACES PAR ELEMENTS (ISSU DE DOMA) 17 : C MELEME POINTEUR DU MAILLAGE 18 : C 19 : C SORTIES 20 : C IZVIT POINTEUR DU SEGMENT CONTENANT LES POINTEURS DES IZUN 21 : C 22 : C ON SUPPOSE QUE NSOUPO=1 (CONTROLE EN AMONT) 23 : C 24 : CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 25 : -INC CCOPTIO 26 : -INC SMELEME 27 : -INC SMTABLE 28 : POINTEUR MTABTT.MTABLE,MTABFT.MTABLE 29 : -INC SMCHPOI 30 : -INC SMCHAML 31 : -INC SMCOORD 32 : -INC SMINTE 33 : C 34 : SEGMENT IPMAHY 35 : INTEGER MAHYBR(NSOUS) 36 : ENDSEGMENT 37 : SEGMENT HYBSTO 38 : REAL*8 HYBASE(NDIM,NBDDL,NBPP) 39 : ENDSEGMENT 40 : C 41 : POINTEUR IELTFA.MELEME 42 : SEGMENT IZVIT 43 : REAL*8 TEMTRA(NVIPT) 44 : INTEGER IPUN(NBS),IDUN(NBS),IPVPT(NVIPT),IFORML 45 : ENDSEGMENT 46 : C 47 : C IDUN(I) NOMBRE D'ELEMENTS AVANT LE SOUS-MAILLAGE I 48 : C IPVPT POINTEURS DE IZVPT POUR CHAQUE PAS DE TEMPS 49 : C 50 : SEGMENT IZVPT 51 : INTEGER IPUN1(NBS),IPUMAX 52 : 53 : ENDSEGMENT 54 : SEGMENT IZUN 55 : REAL*8 UN(I1,I2,I3) 56 : ENDSEGMENT 57 : POINTEUR IZUN1.IZUN ,IZUN2.IZUN 58 : SEGMENT IZBID 59 : INTEGER ITBID(I2,I3) 60 : ENDSEGMENT 61 : SEGMENT IZPBID 62 : INTEGER IPBID(NBS) 63 : ENDSEGMENT 64 : C 65 : C TABLEAU DE TRAVAIL POUR OPTIMISER LA CHOSE (ELOI JUIN 97) 66 : C 67 : SEGMENT IZTRAV 68 : INTEGER ITRAV(NTRAV) 69 : ENDSEGMENT 70 : C 71 : CHARACTER*8 MTYPI,CHARI,MTYPR,CHARR 72 : LOGICAL LOGRE 73 : C 74 : SEGACT MELEME 75 : SEGACT IELTFA 76 : NBSOUS=IELTFA.LISOUS(/1) 77 : NBSOUM=LISOUS(/1) 78 : IF(NBSOUS.NE.NBSOUM)THEN 78 : CALL ERREUR(21) 79 : RETURN 80 : ENDIF 81 : NBS=NBSOUS 82 : IF(NBSOUS.EQ.0)NBS=1 83 : NVIPT=1 84 : IF(ITR.EQ.3)THEN 85 : C 86 : C CAS D'UN TRANSITOIRE ON VA TROUVER UNE TABLE 87 : C 88 : MTABLE=IPTFL 89 : SEGACT MTABLE 90 : IVALI=1 91 : XVALI=0.D0 92 : IRETI=0 93 : IVALR=0 94 : XVALR=0.D0 95 : MTYPI='MOT' 96 : CHARR=' ' 97 : MTYPR='TABLE' 97 : CALL ACCTAB(MTABLE,MTYPI,IVALI,XVALI,'TEMPS',.TRUE.,IRETI, 98 : # MTYPR,IVALR,XVALR,CHARR,LOGRE,IRETR) 99 : IF(IRETR.EQ.0) RETURN 100 : MTABTT=IRETR 101 : IVALI=1 102 : XVALI=0.D0 103 : IRETI=0 104 : IVALR=0 105 : XVALR=0.D0 106 : MTYPI='MOT' 107 : CHARR=' ' 108 : MTYPR='TABLE' 108 : CALL ACCTAB(MTABLE,MTYPI,IVALI,XVALI,'FLUX',.TRUE.,IRETI,MTYPR, 109 : # IVALR,XVALR,CHARR,LOGRE,IRETR) 110 : IF(IRETR.EQ.0) RETURN 111 : MTABFT=IRETR 112 : SEGACT MTABTT,MTABFT 113 : NVIPT=MTABTT.MLOTAB 114 : ENDIF 115 : SEGINI IZVIT 116 : SEGINI IZPBID 117 : IFORML=2 117 : CALL INITI(IDUN,NBS,0) 117 : CALL INITI(IPUN,NBS,0) 117 : CALL INITI(IPBID,NBS,0) 118 : IPT1=IELTFA 119 : IPT3=MELEME 120 : 121 : C 122 : C ON PREPARE LE MCHAML 123 : C 124 : SEGACT MCHELM 125 : MCHAML=ICHAML(1) 126 : SEGACT MCHAML 127 : MELVAL=IELVAL(1) 128 : SEGACT MELVAL 129 : C 130 : C ON PREPARE LE CHPOINT 131 : C 132 : IF(ITR.NE.3) THEN 133 : MCHPO1=IPTFL 134 : SEGACT MCHPO1 135 : MSOUPO=MCHPO1.IPCHP(1) 136 : SEGACT MSOUPO 137 : MPOVAL=IPOVAL 138 : SEGACT MPOVAL 139 : IPT2=IGEOC 140 : SEGACT IPT2 141 : NPGEO=IPT2.NUM(/2) 142 : C 143 : C INITIALISATION ET REMPLISSAGE DU SEGMENT DE TRAVAIL (ELOI JUIN 97) 144 : C 145 : NTRAV=NPGEO 146 : SEGINI IZTRAV 147 : C 148 : DO 1 I=1,NTRAV 149 : ITRAV(I)=0 150 : 1 CONTINUE 151 : DO 2 IPGEO=1,NPGEO 152 : IP=IPT2.NUM(1,IPGEO) 153 : IEMAX=ITRAV(/1) 154 : IF (IP.GT.IEMAX) THEN 155 : NTRAV=IP 156 : SEGADJ IZTRAV 157 : DO 3 I=IEMAX+1,NTRAV 158 : ITRAV(I)=0 159 : 3 CONTINUE 160 : ENDIF 161 : ITRAV(IP)=IPGEO 162 : 2 CONTINUE 163 : C 164 : NBREL=0 165 : C 166 : C ON RECHERCHE LA POSITION DES DIFFERENTES VALEURS DU FLUX 167 : C 168 : DO 4 ISOUS=1,NBS 169 : IF(NBSOUS.GT.0)IPT1=IELTFA.LISOUS(ISOUS) 170 : SEGACT IPT1 171 : I2=IPT1.NUM(/1) 172 : I3=IPT1.NUM(/2) 173 : IDUN(ISOUS)=NBREL 174 : ID1=NBREL 175 : NBREL=NBREL+I3 176 : SEGINI IZBID 177 : IPBID(ISOUS)=IZBID 178 : DO 5 IEL=1,I3 179 : DO 6 ID=1,I2 180 : NOE=IPT1.NUM(ID,IEL) 181 : C 182 : C ON UTILISE ICI LE SEGMENT DE TRAVAIL POUR EVITER UNE DOUBLE BOUCLE 183 : C (ELOI JUIN 97) 184 : C 185 : IF (ITRAV(NOE).EQ.0) THEN 186 : WRITE(6,*) 'PROBLEME POUR CONVERTIR LE TABLEAU DE FLUX' 187 : RETURN 188 : ENDIF 189 : ITBID(ID,IEL)=ITRAV(NOE) 190 : 6 CONTINUE 191 : 5 CONTINUE 192 : 4 CONTINUE 193 : C 194 : C ON SUPPRIME LE SEGMENT DE TRAVAIL (ELOI JUIN 1997) 195 : C 196 : SEGSUP IZTRAV 197 : C 198 : SEGINI IZVPT 198 : CALL TRJFL1(MCHPO1,IZPBID,MCHELM,IELTFA,MELEME,IZVPT,NBREL) 199 : 200 : IPVPT(1)=IZVPT 201 : TEMTRA(1)=0.D0 202 : ELSE 203 : C 204 : C CAS D'UNE TABLE (TRANSITOIRE) 205 : C 206 : DO 7 KPT=1,NVIPT 207 : IVALI= KPT-1 208 : XVALI=0.D0 209 : IRETI=0 210 : IVALR=0 211 : XVALR=0.D0 212 : IRETR=0 213 : MTYPI='ENTIER' 214 : CHARI=' ' 215 : CHARR=' ' 216 : MTYPR=' ' 216 : CALL ACCTAB(MTABTT,MTYPI,IVALI,XVALI,CHARI,.TRUE.,IRETI, 217 : # MTYPR,IVALR,XVALR,CHARR,LOGRE,IRETR) 218 : TEMTRA(KPT)=XVALR 219 : IVALI=KPT-1 220 : XVALI=0.D0 221 : IRETI=0 222 : IVALR=0 223 : XVALR=0.D0 224 : MTYPI='ENTIER' 225 : CHARI=' ' 226 : CHARR=' ' 227 : MTYPR='CHPOINT' 227 : CALL ACCTAB(MTABFT,MTYPI,IVALI,XVALI,CHARI,.TRUE.,IRETI, 228 : # MTYPR,IVALR,XVALR,CHARR,LOGRE,IRETR) 229 : MCHPO1=IRETR 230 : SEGACT MCHPO1 231 : IF(KPT.EQ.1)THEN 232 : C 233 : C ON A CONTROLE PLUS HAUT QUE LES IGEOC SONT IDENTIQUES 234 : C 235 : MSOUPO=MCHPO1.IPCHP(1) 236 : SEGACT MSOUPO 237 : MPOVAL=IPOVAL 238 : SEGACT MPOVAL 239 : IPT2=IGEOC 240 : SEGACT IPT2 241 : NPGEO=IPT2.NUM(/2) 242 : C 243 : C INITIALISATION ET REMPLISSAGE DU SEGMENT DE TRAVAIL (ELOI JUIN 97) 244 : C 245 : NTRAV=NPGEO 246 : SEGINI IZTRAV 247 : C 248 : DO 8 I=1,NTRAV 249 : ITRAV(I)=0 250 : 8 CONTINUE 251 : DO 9 IPGEO=1,NPGEO 252 : IP=IPT2.NUM(1,IPGEO) 253 : IEMAX=ITRAV(/1) 254 : IF (IP.GT.IEMAX) THEN 255 : NTRAV=IP 256 : SEGADJ IZTRAV 257 : DO 10 I=IEMAX+1,NTRAV 258 : ITRAV(I)=0 259 : 10 CONTINUE 260 : ENDIF 261 : ITRAV(IP)=IPGEO 262 : 9 CONTINUE 263 : C 264 : NBREL=0 265 : C 266 : C ON RECHERCHE LA POSITION DES DIFFERENTES VALEURS DU FLUX 267 : C 268 : DO 11 ISOUS=1,NBS 269 : IF(NBSOUS.GT.0)IPT1=IELTFA.LISOUS(ISOUS) 270 : SEGACT IPT1 271 : I2=IPT1.NUM(/1) 272 : I3=IPT1.NUM(/2) 273 : IDUN(ISOUS)=NBREL 274 : ID1=NBREL 275 : NBREL=NBREL+I3 276 : SEGINI IZBID 277 : IPBID(ISOUS)=IZBID 278 : DO 12 IEL=1,I3 279 : UE=0.D0 280 : DO 13 ID=1,I2 281 : NOE=IPT1.NUM(ID,IEL) 282 : C 283 : C ON UTILISE ICI LE SEGMENT DE TRAVAIL POUR EVITER UNE DOUBLE BOUCLE 284 : C (ELOI JUIN 97) 285 : C 286 : IF (ITRAV(NOE).EQ.0) THEN 287 : WRITE(6,*) 288 : # 'PROBLEME POUR CONVERTIR LE TABLEAU DE FLUX' 289 : RETURN 290 : ENDIF 291 : ITBID(ID,IEL)=ITRAV(NOE) 292 : 13 CONTINUE 293 : 12 CONTINUE 294 : 11 CONTINUE 295 : C 296 : C ON SUPPRIME LE SEGMENT DE TRAVAIL (ELOI JUIN 1997) 297 : C 298 : SEGSUP IZTRAV 299 : C 300 : ENDIF 301 : SEGINI IZVPT 301 : CALL TRJFL1(MCHPO1,IZPBID,MCHELM,IELTFA,MELEME,IZVPT,NBREL) 302 : IPVPT(KPT)=IZVPT 303 : SEGDES IZVPT 304 : 7 CONTINUE 305 : SEGDES MTABTT,MTABFT,MTABLE 306 : ENDIF 307 : SEGDES MELVAL,MCHAML,MCHELM 308 : IZVPT=IPVPT(1) 309 : SEGACT IZVPT 310 : DO 14 ISOUS=1,NBS 311 : IZBID=IPBID(ISOUS) 312 : SEGSUP IZBID 313 : IZUN1=IPUN1(ISOUS) 314 : SEGACT IZUN1 315 : I1=IZUN1.UN(/1) 316 : I2=IZUN1.UN(/2) 317 : I3=IZUN1.UN(/3) 318 : SEGINI IZUN 319 : IPUN(ISOUS)=IZUN 320 : SEGDES IZUN,IZUN1 321 : 14 CONTINUE 322 : SEGSUP IZPBID 323 : IF(NBSOUS.NE.0)SEGDES MELEME 324 : SEGDES MPOVAL ,IPT2,MSOUPO,MCHPO1 325 : SEGDES IZVIT 326 : C 327 : RETURN 328 : END 329 : 330 : 331 : 332 :
© Cast3M 2003 - All rights reserved.
Disclaimer