C ZEROP SOURCE CHAT 11/03/16 21:34:11 6902 SUBROUTINE ZEROP(IPMODL,MOT,IPCHEL) C_______________________________________________________________________ C C OPERATEUR MCHAML A ZERO C C Entr{es: C ________ C C IPMODL Pointeur sur un MMODEL C MOT Mot indiquant le type du MCHAML @ cr{er C C Sorties: C ________ C C IPCHEL Pointeur sur un MCHAML r{sultat @ ZERO C C Passage aux nouveaux chamelems par i.monnier le 30.8.90 C C_______________________________________________________________________ * IMPLICIT INTEGER(I-N) -INC SMMODEL -INC SMCHAML -INC CCOPTIO -INC SMLREEL * C SEGMENT INFO INTEGER INFELL(JG) ENDSEGMENT ** pile modeles elementaires segment limode(0) * PARAMETER (NMOT=24) CHARACTER*8 LISMOT(NMOT),MOT CHARACTER*50 LISTIT(NMOT) INTEGER MSUPPO(NMOT) CHARACTER*8 CMATE LOGICAL lsupre * DATA LISMOT / 'NOEUD ', 'GRAVITE ', 'RIGIDITE', 'MASSE ', 1 'STRESSES', 'DEPLACEM', 'FORCES ', 'REACTUAL', 1 'FVOLUMIQ', 'GRADIENT', 'CONTRAIN', 'DEFORMAT', 1 'MATERIAU', 'CARACTER', 'TEMPERAT', 'PRINCIPA', 1 'MAHOOKE ', 'HOTANGEN', 'DILATATI', 'VARINTER', 1 'GRAFLEXI', 'VONMISES', 'VIMISTRU', 'DEFINELA'/ * * LES MATERIAUX ET CARACTERISTIQUES SONT MIS AUX NOEUDS * * 'NOEUD ', 'GRAVITE ', 'RIGIDITE', 'MASSE ', DATA MSUPPO / 1 , 2 , 3 , 4 , * 'STRESSES', 'DEPLACEM', 'FORCES ', 'REACTUAL', 1 5 , 1 , 1 , 1 , * 'FVOLUMIQ', 'GRADIENT', 'CONTRAIN', 'DEFORMAT', 1 3 , 5 , 5 , 5 , * 'MATERIAU', 'CARACTER', 'TEMPERAT', 'PRINCIPA', 1 1 , 1 , 5 , 5 , * 'MAHOOKE ', 'HOTANGEN', 'DILATATI', 'VARINTER', 1 3 , 5 , 5 , 5 , * 'GRAFLEXI', 'VONMISES', 'VIMISTRU', 'DEFINELA'/ 1 5 , 5 , 1 , 5/ * DATA LISTIT / 'NOEUD*', 'GRAVITE*', 'RIGIDITE*', 'MASSE*', 1 'STRESSES*', 'DEPLACEMENTS*', 'FORCES*', 1 'REACTUALISATION*', 'FORCES VOLUMIQUES*', 1 'GRADIENT*', 'CONTRAINTES*', 'DEFORMATIONS*', 1 'CARACTERISTIQUES*', 'CARACTERISTIQUES*', 1 'TEMPERATURES*', 'CONTRAINTES PRINCIPALES*', 1 'MATRICE DE HOOKE*', 'MATRICE DE HOOKE TANGENTE*', 1 'DILATATIONS*', 'VARIABLES INTERNES*', 1 'GRADIENT DE FLEXION*','VON MISES*', 1 'VARIABLES INTERNES MICROSTRUCTURES*', 1 'DEFORMATIONS INELASTIQUES*'/ * INATU=0 NHRM=NIFOUR * MMODEL=IPMODL SEGACT MMODEL NSOUS=KMODEL(/1) * garder la formulation mecanique et creer modele equivalent segini limode do im = 1,NSOUS imodel = kmodel(im) segact imodel if (formod(1).eq.'MELANGE'.AND.matmod(1).EQ.'PARALLELE') then segini,imode1=imodel imodel = imode1 formod(1) = 'MECANIQUE' matmod(1) = 'ELASTIQUE' MN3 = INFMOD(/1) NFOR = FORMOD(/2) NOBMOD = IVAMOD(/1) NMAT = 2 segadj imodel matmod(2) = 'ISOTROPE' limode(**) = imodel else if( nefmod.ne.22.and.formod(1).ne.'LIAISON') then limode(**) = imodel endif endif enddo segdes mmodel * test non redondance N1 = 1 if (limode(/1).gt.1) then do 1161 it1 = limode(/1),2,-1 imode1 = limode(it1) segact imode1 do it2 = (it1 - 1) ,1,-1 imode2 = limode(it2) segact imode2 if (imode1.imamod.eq.imode2.imamod.and. & imode1.conmod.eq.imode2.conmod) then limode(it1) = 0 goto 1161 endif enddo N1 = N1 + 1 1161 continue endif is1 = 0 if (limode(/1).gt.0) then segini,mmodel do is = 1,limode(/1) if (limode(is).gt.0) then is1 = is1 + 1 kmodel(is1) = limode(is) endif enddo else call erreur(26) return endif NSOUS=KMODEL(/1) * * CREATION DU MCHELM * CALL PLACE(LISMOT,NMOT,IPLAC,MOT) DO 50 IO=1,50 IF (LISTIT(IPLAC)(IO:IO).EQ.'*') GOTO 60 50 CONTINUE 60 L1=IO-1 N1=NSOUS IF (MSUPPO(IPLAC).EQ.0) THEN N3=3 ELSE N3=6 ENDIF SEGINI MCHELM IPCHEL=MCHELM TITCHE=LISTIT(IPLAC)(1:L1) IFOCHE=IFOUR * * BOUCLE SUR LES SOUS-ZONES * DO 100 ISOUS=1,NSOUS * IMODEL=KMODEL(ISOUS) SEGACT IMODEL IPMAIL=IMAMOD MELE =NEFMOD IF(INFMOD(/1).NE.0) THEN NPINT=INFMOD(1) ELSE NPINT = 0 ENDIF MFR=NUMMFR(MELE) IMACHE(ISOUS)=IPMAIL CONCHE(ISOUS)=CONMOD INFCHE(ISOUS,1)=0 INFCHE(ISOUS,2)=0 INFCHE(ISOUS,3)=NHRM IF (N3.GT.3) THEN INFCHE(ISOUS,5)=0 ENDIF MOCOMP=0 NOBL=0 NFAC=0 * if(infmod(/1).lt.2+msuppo(iplac) ) then CALL ELQUOI(MELE,0,MSUPPO(IPLAC),IPINF,IMODEL) INFO=IPINF MINTE=INFELL(11) NSTRS=INFELL(16) segsup info else MINTE=INFMOD(2+msuppo(iplac)) NSTRS=INFELE(16) endif IF (N3.GT.3) THEN INFCHE(ISOUS,4)=MINTE INFCHE(ISOUS,6)=MSUPPO(IPLAC) ENDIF * * AIGUILLAGE SUIVANT MOT CLE * lsupre=.true. GOTO ( 1, 1, 1, 1, 1, 6, 7,99,99,10,11,12,13,14,15,16, 2, 2, 1 99,20,21,99,23,24) IPLAC * 99 MOTERR(1:8)='CHAMELEM' CALL ERREUR(302) SEGDES IMODEL SEGDES MMODEL SEGSUP MCHELM RETURN * 1 NBROBL=1 NBRFAC=0 NOBL=1 SEGINI NOMID MOCOMP=NOMID LESOBL(1)='SCAL' GOTO 120 * 2 NBROBL=1 NBRFAC=0 NOBL=1 SEGINI NOMID MOCOMP=NOMID LESOBL(1)='MAHO' GOTO 120 * 6 if(lnomid(1).ne.0) then nomid=lnomid(1) segact nomid mocomp=nomid nobl=lesobl(/2) nfac=lesfac(/2) lsupre=.false. else CALL IDDEPL(MFR,IFOUR,MOCOMP,NOBL,NFAC) endif GOTO 120 * 7 if(lnomid(2).ne.0) then nomid=lnomid(2) segact nomid mocomp=nomid nobl=lesobl(/2) nfac=lesfac(/2) lsupre=.false. else CALL IDFORC(MFR,IFOUR,MOCOMP,NOBL,NFAC) endif GOTO 120 * 10 if(lnomid(3).ne.0) then nomid=lnomid(3) segact nomid mocomp=nomid nobl=lesobl(/2) nfac=lesfac(/2) lsupre=.false. else CALL IDGRAD(MFR,IFOUR,MOCOMP,NOBL,NFAC) endif GOTO 120 * 11 if(lnomid(4).ne.0) then nomid=lnomid(4) segact nomid mocomp=nomid nobl=lesobl(/2) nfac=lesfac(/2) lsupre=.false. else CALL IDCONT(IMODEL,IFOUR,MOCOMP,NOBL,NFAC) endif GOTO 120 * 12 if(lnomid(5).ne.0) then nomid=lnomid(5) mocomp=nomid segact nomid nobl=lesobl(/2) nfac=lesfac(/2) lsupre=.false. else CALL IDDEFO(IMODEL,IFOUR,MOCOMP,NOBL,NFAC) endif GOTO 120 * 13 if(lnomid(6).ne.0) then nomid=lnomid(6) mocomp=nomid segact nomid nobl=lesobl(/2) nfac=lesfac(/2) lsupre=.false. else CALL IDMATR(MFR,IMODEL,MOCOMP,NOBL,NFAC) endif GOTO 120 * 14 if(lnomid(7).ne.0) then nomid=lnomid(7) mocomp=nomid segact nomid nobl=lesobl(/2) nfac=lesfac(/2) lsupre=.false. else CALL IDCARB(MELE,IFOUR,MOCOMP,NOBL,NFAC) endif GOTO 120 * 15 if(lnomid(8).ne.0) then nomid=lnomid(8) mocomp=nomid segact nomid nobl=lesobl(/2) nfac=lesfac(/2) lsupre=.false. else CALL IDTEMP(MFR,IFOUR,NPINT,MOCOMP,NOBL,NFAC) endif GOTO 120 * 16 if(lnomid(9).ne.0) then nomid=lnomid(9) segact nomid mocomp=nomid nobl=lesobl(/2) nfac=lesfac(/2) lsupre=.false. else CALL IDPRIN(MFR,IFOUR,MOCOMP,NOBL,NFAC) endif GOTO 120 * 20 if(lnomid(10).ne.0) then nomid=lnomid(10) segact nomid mocomp=nomid nobl=lesobl(/2) nfac=lesfac(/2) lsupre=.false. else CALL IDVARI(MFR,IMODEL,MOCOMP,NOBL,NFAC) endif * NFOR=FORMOD(/2) NMAT=MATMOD(/2) * CALL NOMATE(FORMOD,NFOR,MATMOD,NMAT,CMATE,MATE,INATU) CMATE = CMATEE MATE = IMATEE INATU = INATUU C C Dans le cas d'une loi 'NON_LINEAIRE' 'UTILISATEUR', il peut ne C pas y avoir de variables internes C Dans ce cas UNIQUEMENT on declare artificiellement une variable C interne bidon afin de creer un MCHAML de travail permettant une C prise en charge du modele externe dans COMP coherente avec celle C des autres modeles C IF (NOBL.EQ.0.AND.NFAC.EQ.0.AND. & INATU.LT.0.AND.INATU.GT.-100) THEN NBROBL=1 NBRFAC=0 NOBL=1 SEGINI NOMID MOCOMP=NOMID LESOBL(1)='VARI' ENDIF GOTO 120 * 21 if(lnomid(11).ne.0) then nomid=lnomid(11) segact nomid mocomp=nomid nobl=lesobl(/2) nfac=lesfac(/2) lsupre=.false. else CALL IDGRAF(MFR,IFOUR,MOCOMP,NOBL,NFAC) endif GOTO 120 * 23 if(lnomid(12).ne.0) then nomid=lnomid(12) segact nomid mocomp=nomid nobl=lesobl(/2) nfac=lesfac(/2) lsupre=.false. else CALL IDPHAS(MFR,IMODEL,MOCOMP,NOBL,NFAC) endif GOTO 120 * 24 if(lnomid(13).ne.0) then nomid=lnomid(13) segact nomid mocomp=nomid nobl=lesobl(/2) nfac=lesfac(/2) lsupre=.false. else CALL IDDEIN(IMODEL,IFOUR,MOCOMP,NOBL,NFAC) endif GOTO 120 * 120 CONTINUE IF (NOBL.EQ.0.AND.NFAC.EQ.0) THEN SEGDES IMODEL SEGDES MMODEL SEGSUP MCHELM CALL ERREUR(404) RETURN ENDIF NOMID=MOCOMP SEGACT NOMID N2=NOBL+NFAC SEGINI MCHAML ICHAML(ISOUS)=MCHAML C IF (NOBL.GT.0) THEN C DO 130 IO=1,NOBL NOMCHE(IO)=LESOBL(IO) IF (IPLAC.EQ.17.OR.IPLAC.EQ.18) THEN TYPCHE(IO)='POINTEURLISTREEL' N1PTEL=0 N1EL=0 N2PTEL=1 N2EL=1 SEGINI MELVAL IELVAL(IO)=MELVAL JG=1 SEGINI MLREEL IELCHE(1,1)=MLREEL SEGDES MLREEL SEGDES MELVAL ELSE IF (IPLAC.EQ.20.AND.CMATE.EQ.'SECTION')THEN TYPCHE(IO)='POINTEURMCHAML ' N1PTEL=0 N1EL=0 N2PTEL=1 N2EL=1 SEGINI MELVAL IELVAL(IO)=MELVAL IELCHE(1,1)=0 SEGDES MELVAL ELSE IF (IPLAC.EQ.20.AND.INATU.EQ.74.AND.IO.GT.1) THEN * * MODELE DE MAXWELL - COMPOSANTES AUTRES QUE EPSE * TYPCHE(IO)='POINTEURLISTREEL' N1PTEL=0 N1EL=0 N2PTEL=1 N2EL=1 SEGINI MELVAL IELVAL(IO)=MELVAL JG=NSTRS SEGINI MLREEL IELCHE(1,1)=MLREEL SEGDES MLREEL SEGDES MELVAL ELSE IF (IPLAC.EQ.20.AND.INATU.EQ.106) THEN * * MODELE MAXOTT COMPOSANTE AUTRES QUE REAL*8 * IF((IFOUR.EQ.2.AND.MFR.EQ.1) & .AND.IO.GT.21) THEN TYPCHE(IO)='POINTEURLISTREEL' N1PTEL=0 N1EL=0 N2PTEL=1 N2EL=1 SEGINI MELVAL IELVAL(IO)=MELVAL JG=NSTRS SEGINI MLREEL IELCHE(1,1)=MLREEL SEGDES MLREEL SEGDES MELVAL ELSE IF((IFOUR.EQ.-1.OR.IFOUR.EQ.-3.OR. & IFOUR.EQ.0.OR.IFOUR.EQ.1) & .AND.IO.GT.16) THEN TYPCHE(IO)='POINTEURLISTREEL' N1PTEL=0 N1EL=0 N2PTEL=1 N2EL=1 SEGINI MELVAL IELVAL(IO)=MELVAL JG=NSTRS SEGINI MLREEL IELCHE(1,1)=MLREEL SEGDES MLREEL SEGDES MELVAL ELSE IF((IFOUR.EQ.-2.OR.(IFOUR.EQ.2.AND. & (MFR.EQ.3.OR.MFR.EQ.9))) & .AND.IO.GT.13) THEN TYPCHE(IO)='POINTEURLISTREEL' N1PTEL=0 N1EL=0 N2PTEL=1 N2EL=1 SEGINI MELVAL IELVAL(IO)=MELVAL JG=NSTRS SEGINI MLREEL IELCHE(1,1)=MLREEL SEGDES MLREEL SEGDES MELVAL ELSE TYPCHE(IO)='REAL*8' N1PTEL=1 N1EL=1 N2PTEL=0 N2EL=0 SEGINI MELVAL IELVAL(IO)=MELVAL SEGDES MELVAL ENDIF ELSE TYPCHE(IO)='REAL*8' N1PTEL=1 N1EL=1 N2PTEL=0 N2EL=0 SEGINI MELVAL IELVAL(IO)=MELVAL SEGDES MELVAL ENDIF 130 CONTINUE C ENDIF C IF (NFAC.GT.0) THEN C DO 140 IO=1,NFAC IF(INATU.EQ.106) THEN NOMCHE(IO+NOBL)=LESFAC(IO) TYPCHE(IO+NOBL)='POINTEURLISTREEL' N1PTEL=0 N1EL=0 N2PTEL=1 N2EL=1 SEGINI MELVAL IELVAL(IO+NOBL)=MELVAL JG=NSTRS SEGINI MLREEL IELCHE(1,1)=MLREEL SEGDES MLREEL SEGDES MELVAL ELSE IF (INATU.EQ.74) THEN * * MODELE DE MAXWELL - SUITE * NOMCHE(IO+NOBL)=LESFAC(IO) TYPCHE(IO+NOBL)='POINTEURLISTREEL' N1PTEL=0 N1EL=0 N2PTEL=1 N2EL=1 SEGINI MELVAL IELVAL(IO+NOBL)=MELVAL JG=NSTRS SEGINI MLREEL IELCHE(1,1)=MLREEL SEGDES MLREEL SEGDES MELVAL ELSE NOMCHE(IO+NOBL)=LESFAC(IO) TYPCHE(IO+NOBL)='REAL*8' N1PTEL=1 N1EL=1 N2PTEL=0 N2EL=0 SEGINI MELVAL IELVAL(IO+NOBL)=MELVAL SEGDES MELVAL ENDIF 140 CONTINUE C ENDIF CMATE = CMATEE MATE = IMATEE INATU = INATUU if ((iplac.eq.11.or.iplac.eq.20).and. &(cmate.eq.'MODAL'.or.cmate.eq.'STATIQUE')) then N2 = 1 segadj mchaml endif C 510 CONTINUE SEGDES IMODEL SEGDES MCHAML if(lsupre) SEGSUP NOMID 100 CONTINUE SEGDES MMODEL segsup mmodel,limode SEGDES MCHELM RETURN END