C JACOPO SOURCE MB234859 25/09/08 21:15:42 12358 C======================================================================= C ENTREES : C --------- C IPMODL= pointeur sur un MMODEL C C SORTIES : C -------- C C IPCHE = CHAMELEM contenant les JACOBIENS C IRET = 1 si succes 0 sinon C C Passage au nouveau Chamelem PAR S.RAMAHANDRY le 11/09/90 C CB215821 20/03/2017 : Ajout de la formulation DIFFUSION (MFR=73) C===================================================================== SUBROUTINE JACOPO(IPMODL,IPCHE,IRET) IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) -INC PPARAM -INC CCOPTIO -INC CCHAMP -INC SMCHAML -INC SMMODEL -INC SMELEME -INC SMCOORD -INC SMINTE -INC TMPTVAL SEGMENT TRA REAL*8 XEL(3,NBNN),SHP(6,NBNN),XE(3,NBNN),BPSS(3,3) ENDSEGMENT C SEGMENT TR1 REAL*8 TH(NBN1),TXR(3,3,NBN1),XJ(3,3) ENDSEGMENT C PARAMETER(UN=1.D0,XZER=0.D0) DIMENSION BPSS(3,3) CHARACTER*8 CMATE C SEGACT,MCOORD*NOMOD NHRM = NIFOUR IRET = 1 C C ACTIVATION DU MODELE C MMODEL= IPMODL NSOUS = KMODEL(/1) C C CREATION DU MCHELM C N1= NSOUS L1= 8 N3= 6 SEGINI,MCHELM IPCHE =MCHELM TITCHE='SCALAIRE' IFOCHE=IFOUR C____________________________________________________________________ C C DEBUT DE LA BOUCLE SUR LES DIFFERENTES ZONES C____________________________________________________________________ C DO 500 ISOUS=1,NSOUS C C ON RECUPERE L INFORMATION GENERALE C IMODEL=KMODEL(ISOUS) IPMAIL=IMAMOD IMACHE(ISOUS)=IPMAIL CONCHE(ISOUS)=CONMOD C C TRAITEMENT DU MODELE C MELE = NEFMOD MELEME= IMAMOD C____________________________________________________________________ C C INFORMATION SUR L'ELEMENT FINI C____________________________________________________________________ C MELE =INFELE(1) MFR =INFELE(13) MINTE=INFMOD(7) MINTE1=INFMOD(3) C INFCHE(ISOUS,1)= 0 INFCHE(ISOUS,2)= 0 INFCHE(ISOUS,3)= NHRM INFCHE(ISOUS,4)= MINTE INFCHE(ISOUS,5)= 0 INFCHE(ISOUS,6)= 5 C C INITIALISATION DE MINTE C NBPGAU=POIGAU(/1) C C ACTIVATION DU MELEME C NBNN =NUM(/1) NBELEM=NUM(/2) C C RECHERCHE DE LA TAILLE DES MELVAL A ALLOUER C N1PTEL=NBPGAU N1EL=NBELEM C C CREATION DU MCHAML DE LA SOUS ZONE C NJAC=1 N2 =1 SEGINI,MCHAML ICHAML(ISOUS)=MCHAML NSR=1 NCOSOR=NJAC SEGINI MPTVAL IVAJAC=MPTVAL C C 1 COMPOSANTE C ICOMP = 1 NOMCHE(ICOMP)='SCAL ' TYPCHE(ICOMP)='REAL*8' N2PTEL = 0 N2EL = 0 SEGINI,MELVAL IELVAL(ICOMP)= MELVAL IVAL(ICOMP) = MELVAL C C ERREUR FORMULATION INDISPONIBLE C IF(MFR.EQ.1.OR.MFR.EQ.3.OR.MFR.EQ.5.OR.MFR.EQ.9.OR.MFR.EQ.7 > .OR.MFR.EQ.13.OR.MFR.EQ.33.OR.MFR.EQ.35.OR.MFR.EQ.49 > .OR.MFR.EQ.73) 1 GOTO 44 MOTERR(1:8)=NOMFR(MFR) CALL ERREUR(193) IRET=0 GOTO 9990 C 44 CONTINUE SEGINI,TRA C C ================== FORMULATION JOINT ======================= C C ----------------- Element JOT3 C IF(MFR.EQ.35) THEN IF(MELE.EQ.87) THEN DO 9000 IB=1,NBELEM CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) DO 9002 IC=1,NBPGAU DO ID=1,6 DO IE=1,NBNN SHP(ID,IE)=SHPTOT(ID,IE,IC) ENDDO ENDDO CALL JT3LOC(XE,SHPTOT,NBNN,XEL,BPSS,NOQUAL) IF (NOQUAL.EQ.1) THEN INTERR(1)=IB MOTERR(1:4)='JOT3' CALL ERREUR(765) RETURN ELSE IF(NOQUAL.EQ.2) THEN INTERR(1)=IB MOTERR(1:4)='JOT3' CALL ERREUR(766) RETURN ENDIF NBNONN=NBNN/2 CALL DEVOLU(XEL,SHP,MFR,NBNONN,IFOUR,NIFOUR,2,1.D0,RR,DJAC) IRRT = 0 IF (DJAC.LT.XZER) THEN IRRT = 1 ELSE IF(DJAC.EQ.XZER) THEN IRRT = 2 ENDIF IF(IRRT.NE.0) THEN CALL ERREUR(764) RETURN ENDIF MPTVAL=IVAJAC MELVAL = IVAL(1) IBMN=MIN(IB, VELCHE(/2)) IGMN=MIN(IC, VELCHE(/1)) VELCHE(IGMN,IBMN)=ABS(DJAC) 9002 CONTINUE 9000 CONTINUE C C ----------------- Element JOI4 C ELSE IF (MELE.EQ.88) THEN DO 8000 IB=1,NBELEM CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) DO 8002 IC=1,NBPGAU DO ID=1,6 DO IE=1,NBNN SHP(ID,IE)=SHPTOT(ID,IE,IC) ENDDO ENDDO CALL JO4LOC(XE,SHPTOT,NBNN,XEL,BPSS,NOQUAL) IF (NOQUAL.EQ.1) THEN INTERR(1)=IB MOTERR(1:4)='JOI4' CALL ERREUR(765) RETURN ELSE IF(NOQUAL.EQ.2) THEN INTERR(1)=IB MOTERR(1:4)='JOI4' CALL ERREUR(766) RETURN ENDIF NBNONN=NBNN/2 CALL DEVOLU(XEL,SHP,MFR,NBNONN,IFOUR,NIFOUR,2,1.D0,RR,DJAC) IRRT = 0 IF (DJAC.LT.XZER) THEN IRRT = 1 ELSE IF(DJAC.EQ.XZER) THEN IRRT = 2 ENDIF IF(IRRT.NE.0) THEN CALL ERREUR(764) RETURN ENDIF MPTVAL=IVAJAC MELVAL = IVAL(1) IBMN=MIN(IB, VELCHE(/2)) IGMN=MIN(IC, VELCHE(/1)) VELCHE(IGMN,IBMN)=ABS(DJAC) 8002 CONTINUE 8000 CONTINUE ELSE CALL ERREUR(767) RETURN ENDIF C C ================ FORMULATION MASSIVE ======================= C ELSE IF(MFR.EQ.1.OR.MFR.EQ.33.OR.MFR.EQ.73) THEN DO 1000 IB=1,NBELEM CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) DO 1002 IC=1,NBPGAU DO ID=1,6 DO IE=1,NBNN SHP(ID,IE)=SHPTOT(ID,IE,IC) ENDDO ENDDO CALL JACOBI(XE,SHP,IDIM,NBNN,DJAC) MPTVAL=IVAJAC MELVAL = IVAL(1) IBMN=MIN(IB, VELCHE(/2)) IGMN=MIN(IC, VELCHE(/1)) VELCHE(IGMN,IBMN)=ABS(DJAC) 1002 CONTINUE 1000 CONTINUE GOTO 520 C C ================ FORMULATION COQUE MINCE ===================== C ELSE IF(MFR.EQ.3.OR.MFR.EQ.9) THEN IDI2=IDIM-1 DO 3000 IB=1,NBELEM CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) C IF(IDIM.EQ.2)THEN CALL VPAST2(XE,BPSS) ELSE IF(IDIM.EQ.3) THEN CALL VPAST(XE,BPSS) ENDIF CALL VCORL1(XE,XEL,BPSS,NBNN) DO 3002 IC=1,NBPGAU DO ID=1,6 DO IE=1,NBNN SHP(ID,IE)=SHPTOT(ID,IE,IC) ENDDO ENDDO CALL JACOBI(XEL,SHP,IDI2,NBNN,DJAC) MPTVAL=IVAJAC MELVAL = IVAL(1) IBMN=MIN(IB, VELCHE(/2)) IGMN=MIN(IC,VELCHE(/1)) VELCHE(IGMN,IBMN)=ABS(DJAC) 3002 CONTINUE 3000 CONTINUE GOTO 520 C C ================ FORMULATION POUTRE ET TUYAU ==================== C ELSE IF(MFR.EQ.7.OR.MFR.EQ.13.OR.MFR.EQ.49) THEN IDI2=IDIM-1 DO 7000 IB=1,NBELEM CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) C DO 7002 IC=1,NBPGAU CALL POUJAC(XE,DJAC) MPTVAL=IVAJAC MELVAL = IVAL(1) IBMN=MIN(IB, VELCHE(/2)) IGMN=MIN(IC, VELCHE(/1)) VELCHE(IGMN,IBMN)=DJAC 7002 CONTINUE 7000 CONTINUE GOTO 520 C C ================ FORMULATION COQUE EPAISSE ==================== C ELSE IF(MFR.EQ.5) THEN C NBPGA1=MINTE1.POIGAU(/1) NBN1 =MINTE1.SHPTOT(/2) SEGINI,TR1 C C UNE PETITE HORREUR ON CONSIDERE LES EPAISSEURS CONSTANTES C DO 5010 IC=1,NBNN TH(IC)=UN 5010 CONTINUE DO 5000 IB=1,NBELEM CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) C CALL CQ8LOC(XE,NBN1,MINTE1.SHPTOT,TXR,IRR) C DO 5002 IC=1,NBPGAU E=DZEGAU(IC) CALL COQ8JC(IC,NBN1,E,XE,TH,TXR,SHPTOT,XJ,DJAC,IRR) MPTVAL=IVAJAC MELVAL = IVAL(1) IBMN=MIN(IB, VELCHE(/2)) IGMN=MIN(IC, VELCHE(/1)) VELCHE(IGMN,IBMN)=ABS(DJAC) 5002 CONTINUE 5000 CONTINUE GOTO 520 ENDIF C--------------------------------------------------------------------- C DESACTIVATION DES SEGMENTS PROPRES A LA ZONE GEOMETRIQUE ISOUS C--------------------------------------------------------------------- C 520 CONTINUE MPTVAL=IVAJAC SEGSUP,MPTVAL,TRA 500 CONTINUE SEGDES,MCOORD RETURN C 9990 CONTINUE * C------------------------------------------------------------------- C ERREUR DANS UNE ZONE , DESACTIVATION ET RETOUR C------------------------------------------------------------------- MPTVAL=IVAJAC SEGSUP,MPTVAL * RETURN END