C JACOPO SOURCE CHAT 11/03/16 21:25:50 6902 SUBROUTINE JACOPO(IPMODL,IPCHE,IRET) 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===================================================================== IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) PARAMETER(UN=1.D0,XZER=0.D0) -INC CCOPTIO -INC CCHAMP -INC SMCHAML -INC SMMODEL -INC SMELEME -INC SMCOORD -INC SMINTE C 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 SEGMENT INFO INTEGER INFELL(JG) ENDSEGMENT C SEGMENT MPTVAL INTEGER IPOS(NS) , NSOF(NS) INTEGER IVAL(NCOSOU) CHARACTER*16 TYVAL(NCOSOU) ENDSEGMENT C DIMENSION BPSS(3,3) CHARACTER*8 CMATE C NHRM=NIFOUR IRET=1 C C ACTIVATION DU MODELE C MMODEL= IPMODL SEGACT MMODEL NSOUS=KMODEL(/1) C C CREATION DU MCHELM C N1=NSOUS L1=8 N3=6 SEGINI MCHELM IPCHE=MCHELM TITCHE='SCALAIRE' IFOCHE=IFOUR IRT8=1 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) SEGACT IMODEL IPMAIL=IMAMOD IMACHE(ISOUS)=IPMAIL CONCHE(ISOUS)=CONMOD C C TRAITEMENT DU MODELE C MELE=NEFMOD MELEME=IMAMOD NFOR=FORMOD(/2) NMAT=MATMOD(/2) C____________________________________________________________________ C C INFORMATION SUR L'ELEMENT FINI C____________________________________________________________________ C if(infmod(/1).lt.7) then CALL ELQUOI(MELE,0,5,IPINF,IMODEL) IF (IERR.NE.0) THEN SEGDES IMODEL,MMODEL SEGSUP MCHELM IRET=0 RETURN ENDIF INFO=IPINF MELE =INFELL(1) MFR =INFELL(13) MINTE=INFELL(11) MINTE1=INFELL(12) segsup info else MELE =INFELE(1) MFR =INFELE(13) MINTE=INFMOD(7) MINTE1=INFMOD(8) endif 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 SEGACT MINTE NBPGAU=POIGAU(/1) C C ACTIVATION DU MELEME C SEGACT MELEME 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 NS=1 NCOSOU=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 1 .OR.MFR.EQ.13.OR.MFR.EQ.33.OR.MFR.EQ.35) 1 GOTO 44 MOTERR(1:8)=NOMFR(MFR) CALL ERREUR(193) IRET=0 GOTO 9990 C 44 CONTINUE C 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 9003 ID=1,6 DO 9003 IE=1,NBNN SHP(ID,IE)=SHPTOT(ID,IE,IC) 9003 CONTINUE 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.0.0D0) THEN IRRT = 1 ELSE IF(DJAC.EQ.0.0D0) 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 8003 ID=1,6 DO 8003 IE=1,NBNN SHP(ID,IE)=SHPTOT(ID,IE,IC) 8003 CONTINUE 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.0.0D0) THEN IRRT = 1 ELSE IF(DJAC.EQ.0.0D0) 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 C ELSE IF(MFR.EQ.1.OR.MFR.EQ.33) THEN DO 1000 IB=1,NBELEM CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) DO 1002 IC=1,NBPGAU DO 1003 ID=1,6 DO 1003 IE=1,NBNN SHP(ID,IE)=SHPTOT(ID,IE,IC) 1003 CONTINUE 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 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 3003 ID=1,6 DO 3003 IE=1,NBNN SHP(ID,IE)=SHPTOT(ID,IE,IC) 3003 CONTINUE 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 C ELSE IF(MFR.EQ.7.OR.MFR.EQ.13) 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 C ELSE IF(MFR.EQ.5) THEN SEGACT MINTE1 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 DO 515 IO=1,NJAC IF(IVAL(IO).NE.0) THEN MELVAL=IVAL(IO) SEGDES MELVAL ENDIF 515 CONTINUE SEGSUP MPTVAL C SEGDES MINTE * SEGSUP INFO C SEGDES IMODEL SEGDES MELEME SEGDES MCHAML C IF (MFR.EQ.5) THEN SEGDES MINTE1,TR1 ENDIF C SEGSUP TRA C 500 CONTINUE SEGDES MMODEL SEGDES MCHELM RETURN C C 9990 CONTINUE * C------------------------------------------------------------------- C ERREUR DANS UNE ZONE , DESACTIVATION ET RETOUR C------------------------------------------------------------------- * * * MPTVAL=IVAJAC DO 9993 IO=1,NJAC IF (IVAL(IO).NE.0) THEN MELVAL=IVAL(IO) SEGDES MELVAL ENDIF 9993 CONTINUE SEGSUP MPTVAL * * * SEGDES MELEME SEGDES IMODEL SEGDES MCHAML C SEGDES MMODEL SEGDES MCHELM SEGDES MINTE * SEGSUP INFO RETURN END