C COML6 SOURCE FD218221 26/02/13 21:15:08 12462 SUBROUTINE COML6(iqmod,ipmel,ipcon,indeso,insupp,itruli, > lformu, IRETOU) *-------------------------------------------------------------------- * coml6 : * boucle elements et point d integration * pretraite les caracteristiques et les donnees suivant * le modele, passe a la loi locale, signale les erreurs * d integration, prepare les resultats *---------------------------------------------------------------- IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) -INC PPARAM -INC CCOPTIO -INC CCGEOME -INC CCHAMP -INC SMCHAML -INC SMELEME -INC SMCOORD -INC SMMODEL -INC SMINTE C INCLUDE SMLMOTS ajoute pour le modele metallurgique (T.L. en mai 2018) -INC SMLMOTS * segment deroulant le mcheml -INC DECHE -INC TECOU SEGMENT WRK2 REAL*8 TRAC(LTRAC) ENDSEGMENT SEGMENT MWRKXE REAL*8 XEL(3,NBNN) ENDSEGMENT SEGMENT WRK3 REAL*8 WORK(LW),WORK2(LW2bi) ENDSEGMENT SEGMENT WRK6 REAL*8 BB(NSTRS,NNVARI),R(NSTRS),XMU(NSTRS) REAL*8 S(NNVARI),QSI(NNVARI),DDR(NSTRS),BBS(NSTRS) REAL*8 SIGMA(NSTRS),SIGGD(NSTRS),XMULT(NSTRS),PROD(NSTRS) ENDSEGMENT SEGMENT WRK7 REAL*8 F(NCOURB,2),W(NCOURB),TRUC(NCOURB) ENDSEGMENT SEGMENT WRK8 REAL*8 DD(NSTRS,NSTRS),DDV(NSTRS,NSTRS),DDINV(NSTRS,NSTRS) REAL*8 DDINVp(NSTRS,NSTRS) ENDSEGMENT SEGMENT WRK9 REAL*8 YOG(NYOG),YNU(NYNU),YALFA(NYALFA),YSMAX(NYSMAX) REAL*8 YN(NYN),YM(NYM),YKK(NYKK),YALFA1(NYALF1) REAL*8 YBETA1(NYBET1),YR(NYR),YA(NYA),YKX(NYKX),YRHO(NYRHO) REAL*8 SIGY(NSIGY) INTEGER NKX(NNKX) ENDSEGMENT SEGMENT WRK91 REAL*8 YOG1(NYOG1),YNU1(NYNU1),YALFT1(NYALFT1),YSMAX1(NYSMAX1) REAL*8 YN1(NYN1),YM1(NYM1),YKK1(NYKK1),YALF2(NYALF2) REAL*8 YBET2(NYBET2),YR1(NYR1),YA1(NYA1),YQ1(NYQ1),YRHO1(NYRHO1) REAL*8 SIGY1(NSIGY1) ENDSEGMENT SEGMENT WR10 INTEGER IABLO1(NTABO1) REAL*8 TABLO2(NTABO2) ENDSEGMENT * AM sellier 26_03_20 SEGMENT WR14 INTEGER INLVIA(NBVIA) ENDSEGMENT SEGMENT WRK12 real*8 bbet1,bbet2,bbet3,bbet4,bbet5,bbet6,bbet7,bbet8,bbet9 real*8 bbet10,bbet11,bbet12,bbet13,bbet14,bbet15,bbet16,bbet17 real*8 bbet18,bbet19,bbet20,bbet21,bbet22,bbet23,bbet24,bbet25 real*8 bbet26,bbet27,bbet28,bbet29,bbet30,bbet31,bbet32,bbet33 real*8 bbet34,bbet35,bbet36,bbet37,bbet38,bbet39,bbet40,bbet41 real*8 bbet42,bbet43,bbet44,bbet45,bbet46,bbet47,bbet48,bbet49 real*8 bbet50,bbet51,bbet52,bbet53,bbet54,bbet55 integer ibet1,ibet2,ibet3,ibet4,ibet5,ibet6,ibet7,ibet8 integer ibet9,ibet10,ibet11,ibet12,ibet13,ibet14,ibet15,ibet16 ENDSEGMENT C CB215821 : remonte depuis CMAZZZ (MAZARS) pour recyclage puis suppression SEGMENT WRKK2(0) C CB215821 : remonte depuis CMAXOA & CMAXTA pour recyclage puis suppression SEGMENT WR12(0) segment wrkgur real*8 wgur1,wgur2,wgur3,wgur4,wgur5,wgur6,wgur7 real*8 wgur8,wgur9,wgur10,wgur11,wgur12(6) real*8 wgur13(7), wgur14 real*8 wgur15,wgur16,wgur17 endsegment C C Segment de travail pour la loi 'NON_LINEAIRE' 'UTILISATEUR' appelant C l'integrateur externe specifique UMAT C SEGMENT WKUMAT C Entrees/sorties de la routine UMAT REAL*8 DDSDDE(NTENS,NTENS), SSE, SPD, SCD, & RPL, DDSDDT(NTENS), DRPLDE(NTENS), DRPLDT, & TIME(2), DTIME, TEMP, DTEMP, DPRED(NPRED), & DROT(3,3), PNEWDT, DFGRD0(3,3), DFGRD1(3,3) CHARACTER*16 CMNAME INTEGER NDI, NSHR, NSTATV, NPROPS, & LAYER, KSPT, KSTEP, KINC C Variables de travail LOGICAL LTEMP, LPRED, LVARI, LDFGRD INTEGER NSIG0, NPARE0, NGRAD0 ENDSEGMENT C C Segment de travail pour les lois 'VISCO_EXTERNE' C SEGMENT WCREEP C Entrees/sorties constantes de la routine CREEP REAL*8 SERD CHARACTER*16 CMNAMC INTEGER LEXIMP, NSTTVC, LAYERC, KSPTC C Entrees/sorties de la routine CREEP pouvant varier REAL*8 STV(NSTV), STV1(NSTV), STVP1(NSTV), & STVP2(NSTV), STV12(NSTV), STVP3(NSTV), & STVP4(NSTV), STV13(NSTV), STVF(NSTV), & TMP12, TMP, TMP32, & DTMP12, DTMP, & PRD12(NPRD), PRD(NPRD), PRD32(NPRD), & DPRD12(NPRD), DPRD(NPRD) INTEGER KSTEPC C Autres indicateurs et variables de travail LOGICAL LTMP, LPRD, LSTV INTEGER IVIEX, NPAREC REAL*8 dTMPdt, dPRDdt(NPRD) ENDSEGMENT character*16 modemo character*(LOCHAI) MOTa CHARACTER*4 LEMOT LOGICAL dimped, b_moda2,b_z integer wr13 REAL*8 DDT C====================================================================== wrk6 = 0 wrk7 = 0 wrk8 = 0 wrk9 = 0 wr10 = 0 wr12 = 0 wrk12 = 0 wr13 = 0 wr14 = 0 WRKK2 = 0 wrkgur = 0 wkumat = 0 wcreep = 0 WRKMET = 0 wrk91 = 0 ecou = 0 iecou = 0 necou = 0 xecou = 0 wrk53 = 0 CALL oooprl(1) SEGINI,ecou,iecou,necou,xecou,wrk53 CALL oooprl(0) C write(ioimp,*) ' coml6 ecou ie ne xe',ecou,iecou,necou,xecou,wrk53 C c moterr(1:6) = 'COML6 ' c moterr(7:15) = 'IMODEL' c interr(1) = iqmod c call erreur(-329) C iwrk53 = wrk53 imodel = iqmod MELEME = IMAMOD C C ----------------------------------------------------------------- C Definir /initialiser les segments wrk53, iecou, necou et xecou C ----------------------------------------------------------------- CALL COMDEF(iwrk53,necou,iecou,xecou,iqmod,insupp,ipmint) IF (KERRE.EQ.999) RETURN MINTE = IPMINT C ** write(6,*) 'coml6 240 nucar ',nucar dimped=.false. do jmot = 1,nmat if (matmod(jmot)(1:10).eq.'IMPEDANCE ') dimped = .true. enddo b_moda2 = cmate.EQ.'MODAL ' .OR. cmate.EQ.'STATIQUE' if (dimped) then if (itypel.eq.1) mele = 45 endif * * AM 26_03_20 sellier * recuperation des numeros des variables internes moyennees * IF(INFMOD(/1).GE.13)THEN LULVIA=INFMOD(14) IF(LULVIA.NE.0) THEN JIL=0 MLMOT1=LULVIA SEGACT, MLMOT1 NBVIA=MLMOT1.MOTS(/2) SEGINI WR14 NOMID=LNOMID(10) IF(NOMID.NE.0) THEN SEGACT NOMID DO 251 IU=1,NBVIA LEMOT=MLMOT1.MOTS(IU) * IF(LESOBL(/2).NE.0) THEN DO 252 JU=1,LESOBL(/2) IF (LEMOT.EQ.LESOBL(JU)) THEN INLVIA(IU)=JU JIL=JIL+1 GOTO 251 ENDIF 252 CONTINUE ENDIF * IF(LESFAC(/2).NE.0) THEN DO 253 JU=1,LESFAC(/2) IF (LEMOT.EQ.LESFAC(JU)) THEN INLVIA(IU)=JU JIL=JIL+1 GOTO 251 ENDIF 253 CONTINUE ENDIF * 251 CONTINUE ENDIF c WRITE(IOIMP,77660) (INLVIA(IU),IU=1,NBVIA) 77660 FORMAT(2X,' NUMERO DES VARIABLES INTERNES'/2X,10I5//) IF(JIL.NE.NBVIA) THEN WRITE(IOIMP,77661) NBVIA,JIL 77661 FORMAT(2X,'PROBLEME VARIABLES MOYENNEES NBVIA=',I4,2X, & 'JIL=',I4//) CALL ERREUR(31) ENDIF ENDIF * ENDIF ** fin AM sellier C C FORMULATION METALLURGIE : C remplissage des noms des phases, reactifs, produits et types if (inatuu .eq. 178) then if( ivamod(/1) .lt. 4 ) then CALL ERREUR(21) RETURN endif MLMOT1 = ivamod(1) MLMOT2 = ivamod(2) MLMOT3 = ivamod(3) MLMOT4 = ivamod(4) NBPHAS = MLMOT1.MOTS(/2) NBREAC = MLMOT2.MOTS(/2) segini WRKMET do i = 1, NBPHAS PHASES(i) = MLMOT1.MOTS(i) enddo do i = 1, NBREAC REACTI(i) = MLMOT2.MOTS(i) PRODUI(i) = MLMOT3.MOTS(i) TYPES(i) = MLMOT4.MOTS(i) enddo endif C C ----------------------------------------------------------------- C Creer/renseigner les segments LILUC et PILNEC qui contiennent C LILUC(1,i) = INOMID : pointeur sur un segment nomid C (noms des composantes obl. et fac.) C LILUC(2,i) = PILNEC : pointeur sur un segment pilnec C (deche des composantes obl. et fac.) C ----------------------------------------------------------------- CALL COMOUW(iqmod,ipcon,indeso,ipil,iwrk52,iwrk53,iretou,iwr522) if (ierr.ne.0) return ** write(ioimp,*) 'coml6 339 nucar ',nucar wrk52 = iwrk52 JNPLAS = wrk53.INPLAS C Completer segment IECOU (ajout de valeurs obtenues dans comouw) ** write(6,*) 'nucar',nucar iecou.ICARA=NUCAR iecou.NCXMAT=NMATT iecou.NUMAT1=NUMAT IF (JNPLAS.EQ.26)THEN iecou.INAT=JNPLAS NNVARI=2 NUMAT=NUMAT+4 ELSE IF (JNPLAS.EQ.29.OR.JNPLAS.EQ.142) THEN iecou.INAT=JNPLAS ENDIF CCCCCCC C ----------------------------------------------------------------- C Creation des deche en sortie C ----------------------------------------------------------------- CALL oooprl(1) CALL COMCRI(iqmod,ipcon,IPMINT,indeso,ipil,insupp,iwrk53,iretou) CALL oooprl(0) if (ierr.ne.0) return C C pas de calcul de caracteristiques pour le melange parallele if (lformu.eq.11) then if (cmate.eq.'PARALLEL') goto 3000 endif * IPTR1 = 0 IF (MFRbi.EQ. 1 .OR. MFRbi.EQ.31 .OR. MFRbi.EQ.33 .OR. & MFRbi.EQ.71 .OR. MFRbi.EQ.73) THEN IF (CMATE.EQ.'ORTHOTRO'.OR.CMATE.EQ.'ANISOTRO'.OR. 1 CMATE.EQ.'UNIDIREC') THEN mele1 = MELE npint1 = NPINT nbno1 = NBNO ielei=iele CALL RESHPT(1,nbno1,IELEi,mele1,npint1,IPTR1,IRT1) if (ierr.ne.0) return MINTE2=IPTR1 c* SEGACT,MINTE2 <- cree par respht et actif ENDIF ENDIF C C ----------------------------------------------------------------- C Initialisation des segments de travail supplementaires ..... C ----------------------------------------------------------------- CALL oooprl(1) SEGINI WRK2,WRK3 NBNN = nbnn2 SEGINI,MWRKXE IF (LOGVIS) SEGINI WRK8 IF (JNPLAS.EQ.26) SEGINI WRK6 IF (JNPLAS.EQ.66) SEGINI WRK12 IF (JNPLAS.EQ.38) SEGINI WRKGUR C segini wrk54 iwrk54 = wrk54 C C Objets de travail pour une loi non lineaire externe IF (JNPLAS.LT.0) THEN IF (JNPLAS.EQ.-1) THEN NTENS=SIG0(/1) NPRED=PAREX0(/1) SEGINI,WKUMAT IFORB=IFOURB CALL WKUMA0(iqmod, iwrk52, wkumat, IFORB) C* ELSE IF (JNPLAS.EQ.-2) THEN ELSE NSTV=VAR0(/1)-4 IF (NSTV.EQ.0) NSTV=1 NPRD=PAREX0(/1) SEGINI,WCREEP CALL WCREE0(iqmod, iwrk52, wcreep) ENDIF C*TMP Deb On met dans wrk53.jecher le pointeur de la fonction externe C*TMP Voir plus tard pour affiner via segment wkumat/wcreep... wrk53.jecher = 0 nobmod = ivamod(/1) DO 10 II=1,nobmod IF(TYMODE(II) .EQ. 'MOT ')THEN IVA=IVAMOD(II) CALL QUEVAL(IVA,'MOT ',ier,lgmot,r_z,MOTa,b_z,i_z) IF(ier .NE. 0) CALL ERREUR(5) IF(MOTa(1:8) .EQ. 'LOIEXT ')THEN wrk53.jecher = ivamod(II+1) GOTO 11 ENDIF ENDIF 10 CONTINUE 11 CONTINUE C*TMP Fin ENDIF CALL oooprl(0) C ----------------------------------------------------------------- * * write(6,*)'coml6 ,nel,nbptel,inplas,mfrbi,cmate,mate,ifour,mele' * write(6,*)'coml6 ',nel,nbptel,jnplas,mfrbi,cmate,mate,ifour,mele C C ------------------------------------------------------------ C Boucle (1000) sur les elements du maillage support du imodel C ------------------------------------------------------------ DO 1000 IB=1,NBELEM2 * (MWRKXE) Recuperation des coordonnees des noeuds de l'element CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XEL) * (WRK54) Calcul des axes locaux CALL COMROT(iwrk53,IB,IPTR1,MWRKXE,iwrk54) if (ierr.ne.0) return * CALCUL DE LA LONGUEUR CARACTERISTIQUE DE L'ELEMENT COURANT * POUR MODELE BETON URGC INSA IF ((JNPLAS.GE.99.AND.JNPLAS.LE.101).OR. 1 (JNPLAS.GE.120.AND.JNPLAS.LE.122)) THEN CALL LONGCA(IMAMOD,IB,BID(1)) ENDIF * Modeles non lineaires externes 'NON_LINEAIRE' 'UTILISATEUR' : * - Releve des coordonnees des noeuds de l'element courant, * - Calcul de la longueur caracteristique de l'element courant * - Releve de la matrice de passage DROT du repere local de l'element * fini massif au repere general du maillage IF (JNPLAS.EQ.-1) THEN IF (IPTR1.NE.0) THEN DO 200 J=1,IDIM DO 201 I=1,IDIM DROT(I,J)=TXR(I,J) 201 CONTINUE 200 CONTINUE ENDIF CALL LOCARA(IDIM,NBNN,XEL,LCARAC) ENDIF C C --------------------------------------------------------- C Boucle (100) sur les points d'integration de l'element ib C --------------------------------------------------------- DO 100 IGAU =1,NBGS * -recuperation de valmat et de valcar * -on recupere les contraintes initiales * -on recupere les variables internes * -on recupere les deformations inelastiques initiales si besoin * -on recupere les increments de deformations totales * -on cherche la section de l'element ib * -prise en compte de l'epaisseur et de l'excentrement * dans le cas des coques minces avec ou sans cisaillement * transverse * * on recupere les constantes du materiau * * ------- Remplissage de wrk52 et wrk522 * on recupere les caracteristiques geometriques CALL COMVAL(iqmod,indeso,ipil,iwrk52,iwrk53,ib,igau,iwr522) IF (IERR.NE.0) RETURN * *-------- Quelques arrangements * calcul des contraintes effectives en milieu poreux CALL COMARA(IQMOD,IWRK52,IWRK53,IWRK54,wrk2,wr10, & iretou,necou,iecou,xecou,itruli) IF (IERR.NE.0) RETURN IF (IRETOU.NE.0) GOTO 1990 * >>>>>>>>>> fin du traitement du materiau * C Pour les modeles non lineaires externes : calcul des coordonnees C du point d'integration courant IF (JNPLAS.LT.0) THEN DO 101 IX=1,IDIM r_z = 0.0D0 DO 102 INO=1,NBNN r_z = r_z +XEL(IX,INO)*SHPTOT(1,INO,IGAU) 102 CONTINUE COORGA(IX) = r_z 101 CONTINUE ENDIF C C Branchement suivant la formulation (LISFOR dans coml2) C GOTO (9999,9002,9999,9999,9002,9999,9999,9999,9999,9999,9011,9999, & 9999,9014,9999,9999,9017,9018,9999),lformu C C ================================================================= C FORMULATIONS NON PREVUES (EVENTUEL POINT DE BRANCHEMENT) C ================================================================= 9999 CONTINUE c FORMULATION : THERMIQUE / LIQUIDE / CONVECTION / c DARCY / FROTTEMENT / RAYONNEMENT / c MAGNETODYNAMIQUE / NAVIER_STOKES / c EULER / FISSURE / THERMOHYDRIQUE / c ELECTROSTATIQUE * write(ioimp,*) 'Formulation non implementee' RETURN C C ================================================================= C FORMULATIONS : MECANIQUE / POREUX C ================================================================= 9002 CONTINUE C Traitement comportement mecanique si fusion du materiau C Si composante TFUS et T>TFUS => IFUS = 1 IFUS = 0 nmat = COMMAT(/2) DO jmat=1,nmat C write(6,*) 'COML6, COMMAT(jmat) =',COMMAT(jmat) IF (COMMAT(jmat).EQ.'TFUS ') THEN TFUS1 = XMATF(jmat) TF1 = TUREF(1) IF (TF1.GT.TFUS1) IFUS = 1 C IF (TF1.GT.TFUS1) write(6,*) 'COML6 : TFUS < TF1 =',TF1 C IF (TF1.GT.TFUS1) write(6,*) 'COML6 : INPLAS =',JNPLAS ENDIF ENDDO C IF (b_moda2.or.(dimped.and.inatuu.ge.161.and.inatuu.le.164)) THEN iforb=ifourb nbgmab=nbgmat nlmatb=nelmat xdt = dt CALL cmoda2(wrk52,wrk53,xdt,ib,igau,nbpgau,nbgmab,nlmatb,iforb) ifourb=iforb nbgmat=nbgmab nelmat=nlmatb ELSE if (ifus.eq.1) then jnppla = 3 else jnppla = jnplas+3 endif * Cas VISCO_EXTERNE (inplas = -2) et UMAT (inplas = -1) ** write(6,*) 'coml6 jnppla ',jnppla GOTO( 8, 8, * inplas 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 $ 7,7, 8, 7, 7, 7,111, 7,111, 8,111,111, 7,111, 8, 7, * 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 $ 8, 7,111, 7, 7, 7, 7, 7, 7, 7, 8, 8, 8, 8, 8, * 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 $ 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 7, 7, 7, * 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 $ 111, 8, 8, 8, 7, 7, 8, 7, 8, 8, 8, 8, 8, 8, 8, * 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 $ 7, 8, 7, 8, 8, 8, 8, 8, 8, 7, 8, 8, 8, 8, 8, * 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 $ 7, 7, 8, 8, 8,111, 7,111, 7, 7, 7, 7, 8, 8, 7, * 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 $ 8, 8, 8, 7, 7, 8, 8, 8, 7, 7, 7, 7, 7, 8, 7, * 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 $ 8, 7, 8,111,111, 7, 7, 7,111,111,111,111, 8, 8, 7, * 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 $ 7, 7,111,111, 8, 8, 8, 8, 8, 7, 8, 8, 8, 8, 8, * 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 $ 7, 7, 7, 7, 8, 8, 8, 8, 12, 12, 12, 8, 8,111, 8, * 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 $ 8, 8, 12, 12, 8, 8, 12, 12, 12, 12,12, 12, 12, 12, 7, * 166 167 168 169 170 171 172 173 174 175 176 177 178 179 $ 12, 12, 12, 12, 12, 12, 12, 12, 8, 12, 12, 12, 12 , 12, c <---Sellier-------> * 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 $ 12, 12, 12, 12, 12, 12, 12, 7, 7, 7, 7, 7, 7, 8, 8, * 195 196 197 $ 8, 8, 8 $ )jnppla 111 continue * write(ioimp,*) ' stop dans coml6 : comportement pas prevu ici' * write(ioimp,*) ' inplas jnppla ',jnplas,jnppla CALL erreur(5) return 7 continue ** if(ib.eq.1.and.igau.eq.1) write(ioimp,*) 'appel coml7' CALL coml7(iqmod,iwrk52,iwrk53,iwrk54,ib,igau, & wrk2,mwrkxe,wrk3,wrk7,wrk8,wrk9,wrk91,iretou, & wr13,wr14,ecou,iecou,necou,xecou,ifus) ** write(6,*) 'apres coml7 kerre ',kerre go to 2000 8 continue C if(ib.eq.1.and.igau.eq.1) write(ioimp,*) ' appel coml8' CALL coml8(iqmod,iwrk52,iwrk53,iwrk54,ib,igau, & wrk2,mwrkxe,wrk3,wrk6,wrk7,wrk8,wrk9,wrk91,wr10, & iretou,wrk12,WR12,WRKK2,wrkgur,wkumat,wcreep,ecou,iecou,necou, & xecou) go to 2000 12 continue C if(ib.eq.1.and.igau.eq.1) write(ioimp,*) ' appel coml12' DDT = dt CALL coml12(iqmod,iwrk52,iwrk53,iwrk54,ib,igau, & wrk2,mwrkxe,iretou,iecou,necou,DDT) go to 2000 ENDIF GOTO 2000 C C ================================================================= C FORMULATION : MELANGE (microstructures) C ================================================================= 9011 CONTINUE IF (CMATE.EQ.'MGRAIN ') THEN CALL mgrain(xmat0,ture0,xmatf,turef) * ELSE if (CMATE.EQ.'CEREM ') then * constituer en cas de besoin les nuages d interpolation ipnua1 = int(xmat0(16)) * modemo = 'CEREMREFR' CALL copret(ipnua1,ilent1,modemo) if (ilent1.eq.0) then CALL chist(ipnua1,ilent1,iwrk52,modemo) if (ierr.ne.0) return call compre(ipnua1,ilent1,modemo) endif C modemo = 'CEREMCHAU' ipnua1 = int(xmat0(17)) call copret(ipnua1,ilent2,modemo) if (ilent2.eq.0) then call chist(ipnua1,ilent2,iwrk52,modemo) if (ierr.ne.0) return call compre(ipnua1,ilent2,modemo) endif C call CRPHA3(iwrk52,iwrk53,ilent1,ilent2,IB,igau) C ELSE if (CMATE.EQ.'LEBLOND ') then call clebl3(iwrk52,IB,igau) C ELSE if (CMATE.EQ.'ZTMAX ') then call cztmax(iwrk52,iwrk53, ib,igau) C ELSE if (CMATE.EQ.'TMM_LMT2') then call t4m(iwrk52,iwrk53, ib,igau) C ENDIF GOTO 2000 C C ================================================================= C FORMULATION : LIAISON C ================================================================= 9014 CONTINUE if (itruli.le.0) then c write(ioimp,*) ' stop dans coml6 : itruli <= 0' call erreur(5) return endif if (mate.ge.23) then call coml11(iqmod,wrk52,wrk53,ib,igau,itruli,iretou) else call coml10(iqmod,wrk52,wrk53,ib,igau,itruli,iretou) endif GOTO 2000 C C ================================================================= C FORMULATION : DIFFUSION C ================================================================= 9017 CONTINUE * write(ioimp,*) 'DIFFUSION : a faire !!!' CALL coml14(iqmod,iwrk52,iwrk53,ib,igau,iretou) GOTO 2000 C C ================================================================= C FORMULATION : METALLURGIE C ================================================================= 9018 CONTINUE C Modele metallurgie cree par T.L. en mai 2018 CALL METALL(iwrk52, WRKMET) GOTO 2000 C C ================================================================= * * Gestion des erreurs * 2000 CONTINUE if (ierr.ne.0) return * * - problemes de convergence * interr(3) = jnplas CALL DEFER1(JNOID,KERR1,KERRE,LOGSUC) if (ierr.ne.0) return * * - autres problemes * 1990 CONTINUE IF (kerre.NE.0) THEN jmfr = mfrbi jmele = mele jkerr1 = kerr1 jkerre = kerre if (jnplas.LT.0) MOTERR(5:20) = wkumat.cmname(1:16) CALL DEFER2(JNPLAS,JMFR,JMELE,IB,IGAU, jkerr1,jkerre) if (ierr.ne.0) return ENDIF c c remplissage des melval contenant les contraintes a la fin * ( rearrangement pour milieu poreux ), c les variables internes finales c et les increments de deformations plastiques c stocke pas de temps optimal c CALL COMSOR(iqmod,ipil,iwrk52,iwrk53,iwrk54,ib,igau,iecou,xecou) if (ierr.ne.0) return C 100 CONTINUE C ------------------------------------------------------------------- C Fin de la boucle (100) sur les points d'integration de l'element ib C ------------------------------------------------------------------- C c special poutres et tuyaux sauf timoschenko if (.not.dimped) then CALL COMPOU(IB,mwrkxe,ipil,iwrk53) if (ierr.ne.0) return endif C 1000 CONTINUE C ---------------------------------------------------------------------- C Fin de la boucle (1000) sur les elements du maillage support du imodel C ---------------------------------------------------------------------- C C Destruction des segments de travail if (wrk7.ne.0) SEGSUP wrk7 if (wrk9.ne.0) SEGSUP wrk9 if (wrk91.ne.0) SEGSUP wrk91 SEGSUP WRK2,WRK3 SEGSUP MWRKXE *** IF (WRK6.NE.0) SEGSUP,WRK6 IF (LOGVIS) SEGSUP,WRK8 **** if (wr10.ne.0) segsup wr10 IF (WRK12.NE.0) SEGSUP WRK12 IF (WR12.NE.0) SEGSUP WR12 IF (WRKK2.NE.0) SEGSUP WRKK2 IF (WRKGUR.NE.0) SEGSUP WRKGUR IF (WKUMAT.NE.0) SEGSUP,WKUMAT IF (WCREEP.NE.0) SEGSUP,WCREEP IF (WRKMET.NE.0) SEGSUP,WRKMET segsup wrk54 3000 CONTINUE C =============================================================== C NON LOCAL : MELANGE PARALLELE C =============================================================== IF (lformu.EQ.11.and.cmatee.eq.'PARALLEL') THEN lilcon = ipcon c c traite call coml9(iqmod,ipcon,iwrk53,indeso,IRETOU,insupp) if(ierr.ne.0) return ENDIF c fin traitement non local MELANGE C =============================================================== C 1998 CONTINUE segsup wrk53 segsup ecou,iecou,necou,xecou c Fermeture des melval & destruction des segments associes CALL COMFIN(ipil,iwrk52,iwr522) c return end