C FLUCOQ SOURCE OF166741 24/10/03 21:15:15 12022 C======================================================================= C= F L U C O Q = C= ----------- = C= = C= Fonction : = C= ---------- = C= Calcul des flux nodaux equivalents a une condition de FLUX IMPOSE = C= pour des elements de type COQUE = 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 COQUE = C= IPENVE Pointeur sur l'enveloppe d'un maillage COQUE = C= IPGEOM Pointeur sur un MAILLAGE elementaire du CHPOINT = C= IPOGEO Pointeur sur un MAILLAGE commun au CHPOINT et au COQUE = C= = C======================================================================= SUBROUTINE FLUCOQ (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 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 IFOI=0 DO ISOU=1,NSOU IPCHEL=0 IMODEL=KMODEL(ISOU) ITGEOM=IMAMOD NEF=NEFMOD IPENVE=ITGEOM * 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) * IL Y A DES MAILLAGES COMMUNS AU CHPOINT ET A L'ENVELOPPE IF (IRR.EQ.0) THEN CALL LIROBJ('MAILLAGE',IPOGEO,1,IRET) IF (IERR.NE.0) GOTO 8 * ON DESIRE CONNAITRE LES CARACTERISTIQUES DE CES MAILLAGES IPT3=IPOGEO SEGACT,IPT3 NSOU3=IPT3.LISOUS(/1) IF (NSOU3.EQ.0) THEN NBN2=IPT3.NUM(/1) ENDIF * 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 NEFACE=NUMGEO(NEF) * RECUPERATION DES CARACTERISTIQUES D'INTEGRATION CALL TSHAPE(NEFACE,'GAUSS',IPINTE) * ECHEC DANS L'ACQUISITION DES CARACTERISTIQUES D'INTEGRATION IF (IERR.NE.0) GOTO 8 * 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 8 segact mchel1 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) RETURN ENDIF MLMOTS=MLMOTX SEGACT,MLMOTS NINC=MOTS(/2) IF (NINC.NE.IDIM) THEN CALL ERREUR(21) GOTO 8 ENDIF 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 SEGDES,MLMOTS 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 SEGSUP,IPT3 GOTO 8 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 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 8 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 8 C* CALL ECRCHA('GEOM') CALL DTCHPO(IPCH1) C* CALL ECRCHA('GEOM') CALL DTCHPO(IPFLUX) IPFLUX=IRET ELSE IPFLUX=IPCH1 ENDIF ENDDO * ON N'A PAS TROUVE DE MAILLAGE COMMUN A CETTE PARTIE DE * L'ENVELOPPE ET DU CHPOINT ELSE IF (IRR.EQ.1) THEN IRRT=IRRT+1 ENDIF 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) 8 CONTINUE C RETURN END