C TRJFLU SOURCE CB215821 20/11/25 13:41:32 10792 SUBROUTINE TRJFLU(IPTFL,ITR,MCHELM,IELTFA,MELEME,IZVIT) C IMPLICIT INTEGER(I-N) IMPLICIT REAL*8 (A-H,O-Z) CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C MET LES FLUX SOUS UNE FORME AGREABLE POUR LE C CALCUL DES TRAJECTOIRES (FORMULATION HYBRIDE) C C ENTREES C IPTFL = MCHPOI1 POINTEUR DU CHPOINT DES FLUX PAR FACES C = MTABLE POINTEUR DE LA TABLE RESULTAT DU TRANSITOIRE C ITR = 3 TRANSITOIRE C MCHELM POINTEUR DU MCHAML CONTENANT L'ORIENTATION DU FLUX C IELTFA POINTEUR DU MAILLAGE FACES PAR ELEMENTS (ISSU DE DOMA) C MELEME POINTEUR DU MAILLAGE C C SORTIES C IZVIT POINTEUR DU SEGMENT CONTENANT LES POINTEURS DES IZUN C C ON SUPPOSE QUE NSOUPO=1 (CONTROLE EN AMONT) C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -INC PPARAM -INC CCOPTIO -INC SMELEME -INC SMTABLE POINTEUR MTABTT.MTABLE,MTABFT.MTABLE -INC SMCHPOI -INC SMCHAML -INC SMCOORD -INC SMINTE C SEGMENT IPMAHY INTEGER MAHYBR(NSOUS) ENDSEGMENT SEGMENT HYBSTO REAL*8 HYBASE(NDIM,NBDDL,NBPP) ENDSEGMENT C POINTEUR IELTFA.MELEME SEGMENT IZVIT REAL*8 TEMTRA(NVIPT) INTEGER IPUN(NBS),IDUN(NBS),IPVPT(NVIPT),IFORML ENDSEGMENT C C IDUN(I) NOMBRE D'ELEMENTS AVANT LE SOUS-MAILLAGE I C IPVPT POINTEURS DE IZVPT POUR CHAQUE PAS DE TEMPS C SEGMENT IZVPT INTEGER IPUN1(NBS),IPUMAX ENDSEGMENT SEGMENT IZUN REAL*8 UN(I1,I2,I3) ENDSEGMENT POINTEUR IZUN1.IZUN ,IZUN2.IZUN SEGMENT IZBID INTEGER ITBID(I2,I3) ENDSEGMENT SEGMENT IZPBID INTEGER IPBID(NBS) ENDSEGMENT C C TABLEAU DE TRAVAIL POUR OPTIMISER LA CHOSE (ELOI JUIN 97) C SEGMENT IZTRAV INTEGER ITRAV(NTRAV) ENDSEGMENT C CHARACTER*8 MTYPI,CHARI,MTYPR,CHARR LOGICAL LOGRE C SEGACT MELEME SEGACT IELTFA NBSOUS=IELTFA.LISOUS(/1) NBSOUM=LISOUS(/1) IF(NBSOUS.NE.NBSOUM)THEN CALL ERREUR(21) RETURN ENDIF NBS=NBSOUS IF(NBSOUS.EQ.0)NBS=1 NVIPT=1 IF(ITR.EQ.3)THEN C C CAS D'UN TRANSITOIRE ON VA TROUVER UNE TABLE C MTABLE=IPTFL SEGACT MTABLE IVALI=1 XVALI=0.D0 IRETI=0 IVALR=0 XVALR=0.D0 MTYPI='MOT' CHARR=' ' MTYPR='TABLE' CALL ACCTAB(MTABLE,MTYPI,IVALI,XVALI,'TEMPS',.TRUE.,IRETI, # MTYPR,IVALR,XVALR,CHARR,LOGRE,IRETR) IF(IRETR.EQ.0) RETURN MTABTT=IRETR IVALI=1 XVALI=0.D0 IRETI=0 IVALR=0 XVALR=0.D0 MTYPI='MOT' CHARR=' ' MTYPR='TABLE' CALL ACCTAB(MTABLE,MTYPI,IVALI,XVALI,'FLUX',.TRUE.,IRETI,MTYPR, # IVALR,XVALR,CHARR,LOGRE,IRETR) IF(IRETR.EQ.0) RETURN MTABFT=IRETR SEGACT MTABTT,MTABFT NVIPT=MTABTT.MLOTAB ENDIF SEGINI IZVIT SEGINI IZPBID IFORML=2 CALL INITI(IDUN,NBS,0) CALL INITI(IPUN,NBS,0) CALL INITI(IPBID,NBS,0) IPT1=IELTFA IPT3=MELEME C C ON PREPARE LE MCHAML C SEGACT MCHELM MCHAML=ICHAML(1) SEGACT MCHAML MELVAL=IELVAL(1) SEGACT MELVAL C C ON PREPARE LE CHPOINT C IF(ITR.NE.3) THEN MCHPO1=IPTFL SEGACT MCHPO1 MSOUPO=MCHPO1.IPCHP(1) SEGACT MSOUPO MPOVAL=IPOVAL SEGACT MPOVAL IPT2=IGEOC SEGACT IPT2 NPGEO=IPT2.NUM(/2) C C INITIALISATION ET REMPLISSAGE DU SEGMENT DE TRAVAIL (ELOI JUIN 97) C NTRAV=NPGEO SEGINI IZTRAV C DO 1 I=1,NTRAV ITRAV(I)=0 1 CONTINUE DO 2 IPGEO=1,NPGEO IP=IPT2.NUM(1,IPGEO) IEMAX=ITRAV(/1) IF (IP.GT.IEMAX) THEN NTRAV=IP SEGADJ IZTRAV DO 3 I=IEMAX+1,NTRAV ITRAV(I)=0 3 CONTINUE ENDIF ITRAV(IP)=IPGEO 2 CONTINUE C NBREL=0 C C ON RECHERCHE LA POSITION DES DIFFERENTES VALEURS DU FLUX C DO 4 ISOUS=1,NBS IF(NBSOUS.GT.0)IPT1=IELTFA.LISOUS(ISOUS) SEGACT IPT1 I2=IPT1.NUM(/1) I3=IPT1.NUM(/2) IDUN(ISOUS)=NBREL ID1=NBREL NBREL=NBREL+I3 SEGINI IZBID IPBID(ISOUS)=IZBID DO 5 IEL=1,I3 DO 6 ID=1,I2 NOE=IPT1.NUM(ID,IEL) C C ON UTILISE ICI LE SEGMENT DE TRAVAIL POUR EVITER UNE DOUBLE BOUCLE C (ELOI JUIN 97) C IF (ITRAV(NOE).EQ.0) THEN WRITE(6,*) 'PROBLEME POUR CONVERTIR LE TABLEAU DE FLUX' RETURN ENDIF ITBID(ID,IEL)=ITRAV(NOE) 6 CONTINUE 5 CONTINUE 4 CONTINUE C C ON SUPPRIME LE SEGMENT DE TRAVAIL (ELOI JUIN 1997) C SEGSUP IZTRAV C SEGINI IZVPT CALL TRJFL1(MCHPO1,IZPBID,MCHELM,IELTFA,MELEME,IZVPT,NBREL) IPVPT(1)=IZVPT TEMTRA(1)=0.D0 ELSE C C CAS D'UNE TABLE (TRANSITOIRE) C DO 7 KPT=1,NVIPT IVALI= KPT-1 XVALI=0.D0 IRETI=0 IVALR=0 XVALR=0.D0 IRETR=0 MTYPI='ENTIER' CHARI=' ' CHARR=' ' MTYPR=' ' CALL ACCTAB(MTABTT,MTYPI,IVALI,XVALI,CHARI,.TRUE.,IRETI, # MTYPR,IVALR,XVALR,CHARR,LOGRE,IRETR) TEMTRA(KPT)=XVALR IVALI=KPT-1 XVALI=0.D0 IRETI=0 IVALR=0 XVALR=0.D0 MTYPI='ENTIER' CHARI=' ' CHARR=' ' MTYPR='CHPOINT' CALL ACCTAB(MTABFT,MTYPI,IVALI,XVALI,CHARI,.TRUE.,IRETI, # MTYPR,IVALR,XVALR,CHARR,LOGRE,IRETR) MCHPO1=IRETR SEGACT MCHPO1 IF(KPT.EQ.1)THEN C C ON A CONTROLE PLUS HAUT QUE LES IGEOC SONT IDENTIQUES C MSOUPO=MCHPO1.IPCHP(1) SEGACT MSOUPO MPOVAL=IPOVAL SEGACT MPOVAL IPT2=IGEOC SEGACT IPT2 NPGEO=IPT2.NUM(/2) C C INITIALISATION ET REMPLISSAGE DU SEGMENT DE TRAVAIL (ELOI JUIN 97) C NTRAV=NPGEO SEGINI IZTRAV C DO 8 I=1,NTRAV ITRAV(I)=0 8 CONTINUE DO 9 IPGEO=1,NPGEO IP=IPT2.NUM(1,IPGEO) IEMAX=ITRAV(/1) IF (IP.GT.IEMAX) THEN NTRAV=IP SEGADJ IZTRAV DO 10 I=IEMAX+1,NTRAV ITRAV(I)=0 10 CONTINUE ENDIF ITRAV(IP)=IPGEO 9 CONTINUE C NBREL=0 C C ON RECHERCHE LA POSITION DES DIFFERENTES VALEURS DU FLUX C DO 11 ISOUS=1,NBS IF(NBSOUS.GT.0)IPT1=IELTFA.LISOUS(ISOUS) SEGACT IPT1 I2=IPT1.NUM(/1) I3=IPT1.NUM(/2) IDUN(ISOUS)=NBREL ID1=NBREL NBREL=NBREL+I3 SEGINI IZBID IPBID(ISOUS)=IZBID DO 12 IEL=1,I3 UE=0.D0 DO 13 ID=1,I2 NOE=IPT1.NUM(ID,IEL) C C ON UTILISE ICI LE SEGMENT DE TRAVAIL POUR EVITER UNE DOUBLE BOUCLE C (ELOI JUIN 97) C IF (ITRAV(NOE).EQ.0) THEN WRITE(6,*) # 'PROBLEME POUR CONVERTIR LE TABLEAU DE FLUX' RETURN ENDIF ITBID(ID,IEL)=ITRAV(NOE) 13 CONTINUE 12 CONTINUE 11 CONTINUE C C ON SUPPRIME LE SEGMENT DE TRAVAIL (ELOI JUIN 1997) C SEGSUP IZTRAV C ENDIF SEGINI IZVPT CALL TRJFL1(MCHPO1,IZPBID,MCHELM,IELTFA,MELEME,IZVPT,NBREL) IPVPT(KPT)=IZVPT SEGDES IZVPT 7 CONTINUE SEGDES MTABTT,MTABFT,MTABLE ENDIF SEGDES MELVAL,MCHAML,MCHELM IZVPT=IPVPT(1) SEGACT IZVPT DO 14 ISOUS=1,NBS IZBID=IPBID(ISOUS) SEGSUP IZBID IZUN1=IPUN1(ISOUS) SEGACT IZUN1 I1=IZUN1.UN(/1) I2=IZUN1.UN(/2) I3=IZUN1.UN(/3) SEGINI IZUN IPUN(ISOUS)=IZUN SEGDES IZUN,IZUN1 14 CONTINUE SEGSUP IZPBID IF(NBSOUS.NE.0)SEGDES MELEME SEGDES MPOVAL ,IPT2,MSOUPO,MCHPO1 SEGDES IZVIT C RETURN END