C CHACO2 SOURCE PV 09/03/12 21:16:41 6325 SUBROUTINE CHACO2(IPSONO,IPSON1,IPSON2,IEP,IPGEOM,IPINTE, . IPINT1,IPCHEQ,IPCHE1,IPCHE2) IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) ************************************************************************ * * C H A C O 2 * ----------- * * FONCTION: * --------- * CAS DES SOURCES VOLUMIQUES * COQ6 COQ8 ET COQ4 * * MODULES UTILISES: * ----------------- * -INC CCOPTIO -INC CCREEL -INC SMCHAML -INC SMELEME -INC SMINTE -INC SMCOORD * * PARAMETRES: (E)=ENTREE (S)=SORTIE (+ = CONTENU DANS UN COMMUN) * ----------- * * IPSONO (E) POINTEURS SUR DES SEGMENTS MELVAL CONTENANT LES * IPSON1 SOURCES * IPSON2 * IEP (E) POINTEUR SUR UN SEGMENT MELVAL COTENANT LES EPAISSEUR * IPGEOM (E) POINTEUR SUR UN OBJET MAILLAGE ELEMENTAIRE * IPINTE (E) POINTEUR SUR UN SEGMENT MINTE CONTENANT LES * CARACTERISTIQUES D'INTEGRATION * IPINT1 (E) POINTEUR SUR UN SEGMENT MINTE CONTENANT LES * LES VALEURS DE FONCTION DE FORME AUX NOEUD * +IDIM (E) VOIR CCOPTIO * +XPI (E) VOIR CCREEL * IPCHEQ (S) POINTEURS SUR DES SEGMENTS MELVAL CONTENANT LES * IPCHE1 CHALEURS NODALES EQUIVALENTES * IPCHE2 * * VARIABLES: * ---------- * * XE(3,NBPTEL) = COORDONNEES DES ELEMENTS DANS LE REPERE GLOBAL * DJAC = DETERMINANT DU JACOBIEN EN UN POINT DE GAUSS * A ET A1 = TABLEAUX DE TRAVAIL * * REAL*8 XJ(3,3) SEGMENT,MMAT1 REAL*8 XE(3,NBPTEL),A(NBE,NBE),FORME(NBNO),A1(NBNO,NBNO) REAL*8 EXC(NBNO),EPAI(NBNO),TXR(3,3,NBNO) ENDSEGMENT * * CONSTANTES: * ----------- * PARAMETER ( O1=1.D0,O2=2.D0) DATA X577/.577350269189626D0/ * * AUTEUR, DATE DE CREATION: * ------------------------- * * P. DOWLATYARI AOUT 90 * * LANGAGE: * -------- * * ESOPE + FORTRAN77 * ************************************************************************ * * ON RECUPERE LES VALEURS DES SOURCES * MELVA1=IPSONO SEGACT,MELVA1 NBPTE1=MELVA1.VELCHE(/1) NEL1=MELVA1.VELCHE(/2) MELVA2=IPSON1 SEGACT,MELVA2 MELVA3=IPSON2 SEGACT,MELVA3 * * ON RECUPERE LES CARACTERISTIQUES D'INTEGRATION * MINTE=IPINTE SEGACT,MINTE NBPGAU=POIGAU(/1) NBNO=SHPTOT(/2) MINTE1 = IPINT1 SEGACT,MINTE1 * * ON RECUPERE UN DES MAILLAGES ELEMENTAIRES DE L'ENVELOPPE * MELEME=IPGEOM SEGACT,MELEME NBPTEL=NUM(/1) NEL=NUM(/2) * * INITIALISATION DES MELVALS QUI CONTIENDRA LES CHALEURS EQUIVALENTE * N1PTEL=NBPTEL N1EL=NEL N2PTEL=0 N2EL=0 NBE=3*NBPTEL SEGINI,MELVAL IPCHEQ=MELVAL SEGINI,MELVA4 IPCHE1=MELVA4 SEGINI,MELVA5 IPCHE2=MELVA5 SEGINI,MMAT1 CALL ZERO(EXC,NBNO,1) MELVA6=IEP SEGACT,MELVA6 * * BOUCLE SUR LES ELEMENTS * DO 10 IEL=1,NEL * * ON CHERCHE LES COORDONNEES DES NOEUDS DANS LE REPERE GLOBAL * CALL DOXE(XCOOR,IDIM,NBPTEL,NUM,IEL,XE) * * CALCUL DES AXES LOCAUX AUX NOEUDS DE L'ELEMENT * CALL CQ8LOC(XE,NBPTEL,MINTE1.SHPTOT,TXR,IRR) * IF(IRR.EQ.0)THEN * * EHEC DANS LE CALCUL DES AXES LOCAUX * CALL ERREUR (515) SEGSUP,MMAT1,MELVAL,MELVA4,MELVA5 SEGDES,MELEME,MELVA1,MINTE,MELVA2,MELVA6 SEGDES,MINTE1,MELVA3 RETURN ENDIF * * * ON CREE LE TABLEAU DES EPAISSEURS * IBMN=MIN(IEL,MELVA6.VELCHE(/2)) DO 5 INO = 1,NBNO INMN=MIN(INO,MELVA6.VELCHE(/1)) EPAI(INO) =MELVA6.VELCHE(INMN,IBMN) 5 CONTINUE * CALL ZERO (A,NBE,NBE) * * BOUCLE SUR LES POINTS DE GAUSS * * DO 40 IGAU = 1, NBPGAU * CALL ZERO (A1,NBNO,NBNO) * E3=DZEGAU(IGAU) * * * CALCUL DU JACABIEN * CALL CQ8JCE (IGAU,NBPTEL,E3,XE,EPAI,EXC,TXR,SHPTOT, . XJ,DJAC,IRR) * IF(IRR.LT.0)THEN * * JACOBIEN NUL DANS L'ELEMENT IEL * INTERR(1)=IEL CALL ERREUR (405) SEGSUP,MMAT1,MELVAL,MELVA4,MELVA5 SEGDES,MELEME,MELVA1,MINTE,MELVA2,MELVA6 SEGDES,MINTE1,MELVA3 RETURN ENDIF * * CALCUL DE FORME (TRANSPOSEE)*FORME CONCERNANT LA SURFACE * MOYENNE DO 50 INO=1,NBNO FORME(INO)=SHPTOT(1,INO,IGAU) 50 CONTINUE * DJAC = DJAC*POIGAU(IGAU) * CALL NTNST (FORME,DJAC,NBNO,1,A1) * * ON AJOUTE L'EFFET DE L'EPAISSEUR * C1=(E3/O2)*(E3-O1) C2=O1-E3*E3 C3=(E3/O2)*(E3+O1) * DO 60 I=1,NBE DO 60 J=1,NBE IF(I.LE.NBNO)THEN II=I IF(J.LE.NBNO)THEN JJ=J FACT=C1*C1 ELSEIF(J.GT.NBNO.AND.J.LE.(2*NBNO))THEN JJ=J-NBNO FACT=C1*C2 ELSE JJ=J-2*NBNO FACT=C1*C3 ENDIF ELSEIF(I.GT.NBNO.AND.I.LE.(2*NBNO))THEN II=I-NBNO IF(J.LE.NBNO)THEN JJ=J FACT=C2*C1 ELSEIF(J.GT.NBNO.AND.J.LE.(2*NBNO))THEN JJ=J-NBNO FACT=C2*C2 ELSE JJ=J-2*NBNO FACT=C2*C3 ENDIF ELSE II=I-2*NBNO IF(J.LE.NBNO)THEN JJ=J FACT=C3*C1 ELSEIF(J.GT.NBNO.AND.J.LE.(2*NBNO))THEN JJ=J-NBNO FACT=C3*C2 ELSE JJ=J-2*NBNO FACT=C3*C3 ENDIF ENDIF A(I,J)=A(I,J)+FACT*A1(II,JJ) 60 CONTINUE * FIN DE BOUCLE SUR LES POINTS D'INTEGRATION 40 CONTINUE * * (INTEGRAL DE HTH)*VALEURS NODALES DES SOURCES * IEMIN=MIN(NEL1,IEL) DO 70 INO3=1,NBE DO 70 INO4=1,NBE IF(INO3.LE.NBPTEL)THEN IF(INO4.LE.NBPTEL)THEN INMIN=MIN(NBPTE1,INO4) VELCHE(INO3,IEL)=VELCHE(INO3,IEL)+MELVA1.VELCHE(INMIN,IEMIN)* 1 A(INO4,INO3) ELSEIF(INO4.GT.NBPTEL.AND.INO4.LE.(2*NBPTEL))THEN INO5=INO4-NBPTEL INMIN=MIN(NBPTE1,INO5) VELCHE(INO3,IEL)=VELCHE(INO3,IEL)+MELVA2.VELCHE(INMIN,IEMIN)* 1 A(INO4,INO3) ELSE INO5=INO4-2*NBPTEL INMIN=MIN(NBPTE1,INO5) VELCHE(INO3,IEL)=VELCHE(INO3,IEL)+MELVA3.VELCHE(INMIN,IEMIN)* 1 A(INO4,INO3) ENDIF ELSEIF(INO3.GT.NBPTEL.AND.INO3.LE.(2*NBPTEL))THEN INO6=INO3 - NBPTEL IF(INO4.LE.NBPTEL)THEN INMIN=MIN(NBPTE1,INO4) MELVA4.VELCHE(INO6,IEL)=MELVA4.VELCHE(INO6,IEL)+ 1 MELVA1.VELCHE(INMIN,IEMIN)*A(INO4,INO3) ELSEIF(INO4.GT.NBPTEL.AND.INO4.LE.(2*NBPTEL))THEN INO5=INO4-NBPTEL INMIN=MIN(NBPTE1,INO5) MELVA4.VELCHE(INO6,IEL)=MELVA4.VELCHE(INO6,IEL)+ 1 MELVA2.VELCHE(INMIN,IEMIN)*A(INO4,INO3) ELSE INO5=INO4-2*NBPTEL INMIN=MIN(NBPTE1,INO5) MELVA4.VELCHE(INO6,IEL)=MELVA4.VELCHE(INO6,IEL)+ 1 MELVA3.VELCHE(INMIN,IEMIN)*A(INO4,INO3) ENDIF ELSE INO6=INO3 -2*NBPTEL IF(INO4.LE.NBPTEL)THEN INMIN=MIN(NBPTE1,INO4) MELVA5.VELCHE(INO6,IEL)=MELVA5.VELCHE(INO6,IEL)+ 1 MELVA1.VELCHE(INMIN,IEMIN)*A(INO4,INO3) ELSEIF(INO4.GT.NBPTEL.AND.INO4.LE.(2*NBPTEL))THEN INO5=INO4-NBPTEL INMIN=MIN(NBPTE1,INO5) MELVA5.VELCHE(INO6,IEL)=MELVA5.VELCHE(INO6,IEL)+ 1 MELVA2.VELCHE(INMIN,IEMIN)*A(INO4,INO3) ELSE INO5=INO4-2*NBPTEL INMIN=MIN(NBPTE1,INO5) MELVA5.VELCHE(INO6,IEL)=MELVA5.VELCHE(INO6,IEL)+ 1 MELVA3.VELCHE(INMIN,IEMIN)*A(INO4,INO3) ENDIF ENDIF 70 CONTINUE * END DO 10 CONTINUE * END DO * SEGSUP,MMAT1 SEGDES,MELEME,MELVA1,MINTE,MELVA2,melva6 SEGDES,MELVA3,MELVAL,MELVA4,MELVA5,MINTE1 * END