C FLUMAS SOURCE OF166741 24/10/03 21:15:15 12022 C======================================================================= C= F L U M A S = C= ----------- = C= = C= Fonction : = C= ---------- = C= Calcul des flux nodaux equivalents a une condition de FLUX IMPOSE = C= pour des elements de type MASSIF (1D, 2D, 3D) = C= Sous-programme appele par FLUX2 (flux2.eso) = C= = C= Parametres : (E)=Entree (S)=Sortie = C= ------------ = C= IPMODE (E) Pointeur sur le segment MMODEL = C= IPGEOM (E) Objet MAILLAGE support de IPCHPO = C= IPCHPO (E) Pointeur sur le CHPOINT (ou le MCHAML) de flux = C= imposes aux noeuds de la structure = C= (champ variable ou constant) = C= NUMPOI (E) Vaut -1 si le flux impose est normal a la surface, = C= sinon pointeur sur un POINT correspondant a la = C= direction du flux (par rapport au repere global) = C= MOCOMP (E) Nom de la composante du champ de flux equivalents = C= MLMOTX (E) Pointeur MLMOTS de la liste des composantes de = C= IPCHPO associees aux 3 directions x,y,z. = C= IPFLUX (S) Pointeur sur le champ des flux nodaux equivalents = C= = C= Variables locales : = C= ------------------- = C= ITGEOM Pointeur sur un MAILLAGE elementaire du MASSIF = C= IPENVE Pointeur sur l'enveloppe d'un maillage MASSIF = C= IPGEOM Pointeur sur un MAILLAGE elementaire du CHPOINT = C= IPOGEO Pointeur sur un MAILLAGE commun au CHPOINT et au MASSIF = C= = C= Denis ROBERT, le 1er fevrier 1988. = C======================================================================= SUBROUTINE FLUMAS (IPMODE,IPGEOM,IPCHPO,NUMPOI,NOMCQ,MLMOTX, & IPFLUX) IMPLICIT INTEGER(I-N) IMPLICIT REAL*8 (A-H,O-Z) -INC PPARAM -INC CCOPTIO -INC CCHAMP -INC CCREEL -INC SMCHAML -INC SMCHPOI -INC SMMODEL -INC SMELEME -INC SMCOORD -INC SMLMOTS CHARACTER*(*) NOMCQ PARAMETER (XUn=1.) DIMENSION IVAL(4) CHARACTER*(LOCOMP) IMOT1,IMOT2 C= Activation du MMODEL MMODEL=IPMODE NSOU=KMODEL(/1) C= Activation de MLMOTX si defini NINC = 0 IF (MLMOTX.NE.0) THEN MLMOTS=MLMOTX SEGACT,MLMOTS NINC = MOTS(/2) ENDIF C BOUCLE SUR LES ZONES ELEMENTAIRES DU MODELE C ============================================= idimp1=IDIM+1 IRRT=0 DO ISOU=1,NSOU IPCHEL=0 IMODEL=KMODEL(ISOU) NEF=NEFMOD * Determination de l'ENVELOPPE du MASSIF ITGEOM=IMAMOD CALL ECROBJ('MAILLAGE',ITGEOM) IF (IDIM.EQ.3) THEN CALL ENVELO ELSE IF (IDIM.EQ.2) THEN CALL PRCONT ELSE IF (IDIM.EQ.1) THEN CALL PREX1D ENDIF CALL LIROBJ('MAILLAGE',IPENVE,1,IRET) CALL ACTOBJ('MAILLAGE',IPENVE,1) IF (IERR.NE.0) GOTO 9900 * ON RECUPERE LES MAILLAGES ELEMENTAIRES DE L'ENVELOPPE * APPUYES STRICTEMENT SUR LE CHPOINT DE FLUX CALL ECROBJ('MAILLAGE',IPGEOM) CALL ECRCHA('STRI') CALL ECRCHA('APPU') CALL ECROBJ('MAILLAGE',IPENVE) CALL EXTREL(IRR,0,i) * Pas DE MAILLAGE COMMUN A CETTE PARTIE DE L'ENVELOPPE ET DU CHPOINT IF (IRR.EQ.1) THEN IRRT=IRRT+1 GOTO 9900 ENDIF * IL Y A DES MAILLAGES COMMUNS AU CHPOINT ET A L'ENVELOPPE CALL LIROBJ('MAILLAGE',IPOGEO,1,IRET) CALL ACTOBJ('MAILLAGE',IPOGEO,1) IF (IERR.NE.0) GOTO 9900 * ON DESIRE CONNAITRE LES CARACTERISTIQUES DE CES MAILLAGES IPT3=IPOGEO SEGACT,IPT3 NSOU3=IPT3.LISOUS(/1) IF (NSOU3.EQ.0) NBN2=IPT3.NUM(/1) * BOUCLE SUR LES ZONES DE CET OBJET GEOMETRIQUE DO IMAIL=1,MAX(1,NSOU3) IF (NSOU3.NE.0) THEN IPT2=IPT3.LISOUS(IMAIL) SEGACT,IPT2 IPOGEO=IPT2 NBN2=IPT2.NUM(/1) ENDIF * RECHERCHE DE LA FORMULATION DES (SUR)FACES POUR LES MASSIF CALL FLUX3(NEF,NBN2,NEFACE) * IMPOSSIBLE D'UTILISER L'OPERATEUR FLUX POUR LES ELEMENTS DE TYPE NEF IF (NEFACE.EQ.0) THEN MOTERR(1:4)=NOMTP(NEF) CALL ERREUR(407) GOTO 9901 ENDIF * RECUPERATION DES CARACTERISTIQUES D'INTEGRATION CALL TSHAPE(NEFACE,'GAUSS',IPINTE) * ECHEC DANS L'ACQUISITION DES CARACTERISTIQUES D'INTEGRATION IF (IERR.NE.0) GOTO 9901 * ON GENERE UN CHAMELEM ELEMENTAIRE DE FLUX * A PARTIR DU MAILLAGE ELEMENTAIRE DE POINTEUR IPOGEO * ET DU CHPOINT if (IPCHPO.gt.0) then CALL CHAME1(IPOGEO,0,IPCHPO,' ',ICHELF,6) else *ou ET DU MCHAML ICHE = -1*IPCHPO CALL REDUIC(ICHE,IPOGEO,ICHELF) endif MCHEL1=ICHELF IF (IERR.NE.0) GOTO 9901 MCHAM1=MCHEL1.ICHAML(1) NBCOMP=MCHAM1.IELVAL(/1) IF (NBCOMP.EQ.1) THEN IPFLOD=MCHAM1.IELVAL(1) ELSE C POUR CHAQUE ELEMENT, C ON DETERMINE UN VECTEUR DIRIGE VERS L INTERIEUR DU MASSIF C A PARTIR D UN POINT DE LA FACE ET DU CENTRE DE GRAVITE DU MASSIF C ON COPIE LE CHAMP EN AJOUTANT UNE COMPOSANTE IF (MLMOTX.EQ.0) THEN MOTERR(1:8)='LISTMOTS' CALL ERREUR(37) GOTO 9901 ENDIF MLMOTS=MLMOTX MELVAL=MCHAM1.IELVAL(1) N1PTEL=VELCHE(/1) N1EL=VELCHE(/2) N2PTEL=0 N2EL=0 NBCOMP=IDIM N2=NBCOMP+IDIM SEGINI,MCHAML IPFLOD=MCHAML DO I=1,N2 SEGINI,MELVAL IELVAL(I)=MELVAL ENDDO DO I=1,NINC IMOT1=MOTS(i) DO J=1,NINC IMOT2=MCHAM1.NOMCHE(J) IF (IMOT1.EQ.IMOT2) IVAL(I)=J ENDDO ENDDO DO I=1,NBCOMP MELVA1=MCHAM1.IELVAL(IVAL(I)) MELVAL=IELVAL(I) DO j=1,N1EL DO k=1,N1PTEL VELCHE(k,j)=MELVA1.VELCHE(k,j) ENDDO ENDDO ENDDO NBPTE1=N1PTEL NEL1=N1EL NUMPOI=1 MELEME=IPOGEO IPT1=ITGEOM NBMA1=NUM(/1) DO IEF=1,NUM(/2) DO IEM=1,IPT1.NUM(/2) JNE=0 DO INM=1,IPT1.NUM(/1) DO INF=1,NBMA1 IF (IPT1.NUM(INM,IEM).EQ.NUM(INF,IEF)) JNE=JNE+1 ENDDO ENDDO IF (JNE.EQ.NBMA1) GOTO 170 ENDDO DO j=1,N2 MELVAL=IELVAL(j) SEGSUP,MELVAL ENDDO CALL ERREUR(21) GOTO 9901 C CDG element de "volume" C CDG de la "face" C Calcul de la normale interieure (stocker dans MCHAML) 170 NBM=IPT1.NUM(/1) IF (IDIM.EQ.2) THEN XG=XZero YG=XZero DO INM=1,NBM IREFM=(IPT1.NUM(INM,IEM)-1)*idimp1 XG=XG+XCOOR(IREFM+1) YG=YG+XCOOR(IREFM+2) ENDDO XG=XG/NBM YG=YG/NBM XK=XZero YK=XZero DO INF=1,NBMA1 IREFF=(NUM(INF,IEF)-1)*idimp1 XK=XK+XCOOR(IREFF+1) YK=YK+XCOOR(IREFF+2) ENDDO XK=XK/NBMA1 YK=YK/NBMA1 V1=XG-XK V2=YG-YK VN=SQRT(V1*V1+V2*V2) V1=V1/VN V2=V2/VN DO INF=1,NBMA1 MELVAL=IELVAL(NBCOMP+1) VELCHE(INF,IEF)=V1 MELVAL=IELVAL(NBCOMP+2) VELCHE(INF,IEF)=V2 ENDDO ELSE IF (IDIM.EQ.3) THEN XG=XZero YG=XZero ZG=XZero DO INM=1,NBM IREFM=(IPT1.NUM(INM,IEM)-1)*idimp1 XG=XG+XCOOR(IREFM+1) YG=YG+XCOOR(IREFM+2) ZG=ZG+XCOOR(IREFM+3) ENDDO XG=XG/NBM YG=YG/NBM ZG=ZG/NBM XK=XZero YK=XZero ZK=XZero DO INF=1,NBMA1 IREFF=(NUM(INF,IEF)-1)*idimp1 XK=XK+XCOOR(IREFF+1) YK=YK+XCOOR(IREFF+2) ZK=ZK+XCOOR(IREFF+3) ENDDO XK=XK/NBMA1 YK=YK/NBMA1 ZK=ZK/NBMA1 V1=XG-XK V2=YG-YK V3=ZG-ZK VN=SQRT(V1*V1+V2*V2+V3*V3) V1=V1/VN V2=V2/VN V3=V3/VN DO INF=1,NBMA1 MELVAL=IELVAL(NBCOMP+1) VELCHE(INF,IEF)=V1 MELVAL=IELVAL(NBCOMP+2) VELCHE(INF,IEF)=V2 MELVAL=IELVAL(NBCOMP+3) VELCHE(INF,IEF)=V3 ENDDO ELSE IF (IDIM.EQ.1) THEN XG=XZero DO INM=1,NBM IREFM=(IPT1.NUM(INM,IEM)-1)*idimp1 XG=XG+XCOOR(IREFM+1) ENDDO XG=XG/NBM XK=XZero DO INF=1,NBMA1 IREFF=(NUM(INF,IEF)-1)*idimp1 XK=XK+XCOOR(IREFF+1) ENDDO XK=XK/NBMA1 V1=XG-XK V1=V1/ABS(V1) DO INF=1,NBMA1 MELVAL=IELVAL(NBCOMP+1) VELCHE(INF,IEF)=V1 ENDDO ENDIF ENDDO ENDIF * CHAMELEM ELEMENTAIRE DES FLUX NODAUX EQUIVALENTS L1=7 N1=1 N3=6 SEGINI,MCHELM IPCHEL=MCHELM TITCHE='CHALEUR' IFOCHE=IFOUR IMACHE(1)=IPOGEO CONCHE(1)=CONMOD INFCHE(1,6)=1 N2=1 SEGINI,MCHAML ICHAML(1)=MCHAML NOMCHE(1)='FLUX' TYPCHE(1)='REAL*8' * CALCUL DES FLUX NODAUX EQUIVALENTS * FACES ASSOCIEES SEG2 OU SEG3 IF (NEFACE.EQ.2.OR.NEFACE.EQ.3) THEN CALL FLUMA2(IPFLOD,IPOGEO,IPINTE,NUMPOI,IPFLEQ) * FACES ASSOCIEES TRI3,TRI6,QUA4 OU QUA8 ELSE IF (NEFACE.EQ. 4.OR.NEFACE.EQ.6.OR.NEFACE.EQ.8.OR. . NEFACE.EQ.10) THEN CALL FLUMA3(IPFLOD,IPOGEO,IPINTE,NUMPOI,IPFLEQ) * FACES ASSOCIEES POI1 ELSE IF (NEFACE.EQ.45) THEN CALL FLUMA1(IPFLOD,IPOGEO,IPINTE,NUMPOI,IPFLEQ) ENDIF IF (NUMPOI.EQ.1) THEN MCHAM2=IPFLOD DO i=1,MCHAM2.IELVAL(/1) MELVAL=MCHAM2.IELVAL(i) SEGSUP,MELVAL ENDDO SEGSUP,MCHAM2 ENDIF IF (IERR.NE.0) THEN SEGSUP,MCHAML,MCHELM GOTO 9901 ENDIF IELVAL(1)=IPFLEQ * ON TRANSFORME LE CHAMELEM EN CHPOINT CALL CHAMPO(IPCHEL,0,IPCH1,IDUM) MCHPOI=IPCH1 DO i=1,IPCHP(/1) MSOUPO=IPCHP(i) NOCOMP(1)=nomcq ENDDO CALL DTCHEL(IPCHEL) * ON REGROUPE,LE CAS ECHEANT,LES DIFFERENTS CHPOINTS IF ((ISOU-IRRT).GT.1.OR.IMAIL.GT.1) THEN CALL ADCHPO(IPCH1,IPFLUX,IRET,XUn,XUn) IF (IRET.EQ.0) GOTO 9901 C* CALL ECRCHA('GEOM') CALL DTCHPO(IPCH1) C* CALL ECRCHA('GEOM') CALL DTCHPO(IPFLUX) IPFLUX=IRET ELSE IPFLUX=IPCH1 ENDIF ENDDO 9901 CONTINUE 9900 CONTINUE IF (IERR.NE.0) GOTO 9999 ENDDO * IL N'EXISTE PAS D'ELEMENTS COMMUNS AU CHPOINT DES FLUX NODAUX * ET A L'ENVELOPPE DU MASSIF IF (IRRT.EQ.NSOU) CALL ERREUR(408) 9999 CONTINUE END