C FPCOQU SOURCE CHAT 11/03/16 21:22:58 6902 SUBROUTINE FPCOQU(P,IPCHE1,IPMODL,JMLU,IPTFP,IRET,ICONV) *_____________________________________________________________________ * * CALCULE LES FORCES DE PRESSIONS APPLIQUEES SUR DES COQUES * * ENTREES : * --------- * * P VALEUR DE LA PRESSION SI ELLE EST CONSTANTE * IPCHE1 CHPOINT CONTENANT LES VALEURS DES PRESSIONS AUX NOEUDS * ICONV FLAG DE CONVERSION * IPMODL OBJET AFFECTE SUR LEQUEL S APPLIQUE LA PRESSION * JMLU 1 SI MOT CLE NORMAL * 0 SINON IL FAUT APPELER PRORIE * 0 SI LE MOT CLE NORM A ETE INDIQUE * * SORTIES : * --------- * * IPTFP CHPOINT DES FORCES NODALES EQUIVALENTES * IRET 1 OU 0 SUIVANT SUCCES OU NON * * * REVISION JACQUELINE BROCHARD SEPTEMBRE 86 * * PASSAGE AUX NOUVEAUX MCHAMLS PAR JM CAMPENON LE 05 09 90 * *_____________________________________________________________________ * IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) -INC CCOPTIO -INC CCHAMP -INC SMCOORD -INC SMELEME -INC SMMODEL -INC SMCHAML -INC SMCHPOI -INC SMINTE * logical ltelq SEGMENT NOTYPE CHARACTER*16 TYPE(NBTYPE) ENDSEGMENT * SEGMENT MPTVAL INTEGER IPOS(NS) ,NSOF(NS) INTEGER IVAL(NCOSOU) CHARACTER*16 TYVAL(NCOSOU) ENDSEGMENT * * Segment donnant le pointeur de maillage correcte au MCHAML de * caracteristique apres creation d'un MMODEL * SEGMENT JPMAIL INTEGER MAIL1 (NSOUS1) INTEGER MAIL2 (NSOUS1) ENDSEGMENT * CHARACTER*8 MOT CHARACTER*(NCONCH) CONM PARAMETER (NINF=3) INTEGER INFOS(NINF) LOGICAL lsupfo DATA MOT/'NOEUD '/ * IRET = 0 NHRM=NIFOUR * IFLAG=0 IND=0 IVACAR=0 IPCHE2=0 JPMAIL=0 * * LE FLAG SERT A INDIQUER SI L'ON DOIT OU NON DETRUIRE LE MODELE * EN CAS DE CREATION ( 0 : DESTRUCTION D'UN MMODEL CREE ) * IF (IPCHE1.NE.0) THEN * * ON CREE LE MMODEL S'ACCROCHANT AU CHPOINT * CALL NOMCOM(IPCHE1,'SCAL',IPCHE,IRETOU) IF (IERR.NE.0) RETURN * * ON CREE L OBJET MAILLAGE CONTENANT TOUS LES POINT DU CHPOINT * MCHPOI=IPCHE SEGACT MCHPOI NSOUPO=IPCHP(/1) IPGEOM = 0 DO 1140 I=1,NSOUPO MSOUPO=IPCHP(I) SEGACT MSOUPO IF (IPGEOM.EQ.0) THEN IPGEOM = IGEOC ELSE IPP2 = IGEOC ltelq=.false. CALL FUSE (IPGEOM,IPP2,IPPT,ltelq) IPGEOM = IPPT ENDIF SEGDES MSOUPO 1140 CONTINUE SEGDES MCHPOI * N1=0 SEGINI MMODEL IPMOD=MMODEL * MMODE1=IPMODL SEGACT MMODE1 NSOUS1=MMODE1.KMODEL(/1) * * BOUCLE SUR LES SOUS ZONE GEOMETRIQUE ELEMENTAIRE * IRRT=0 DO 50 ISOUS=1,NSOUS1 IMODE1=MMODE1.KMODEL(ISOUS) SEGACT IMODE1 ITGEOM=IMODE1.IMAMOD CALL ECROBJ('MAILLAGE',IPGEOM) CALL ECRCHA('STRI') CALL ECRCHA('APPU') CALL ECROBJ('MAILLAGE',ITGEOM) CALL EXTREL(IRR,0,IBNOR) IF (IRR.EQ.0) THEN * * ON A VERIFIER L ADHERENCE DU CHPOINT A CE MAILLAGE * CALL LIROBJ('MAILLAGE',IPOGEO,1,IRETOU) IF (IERR.NE.0) THEN SEGDES MMODE1 SEGDES IMODE1 SEGSUP MMODEL RETURN ENDIF N1=N1+1 SEGADJ MMODEL * * CREATION DE L'OBJET IMODEL DE CETTE SOUS ZONE * NFOR=IMODE1.FORMOD(/2) NMAT=IMODE1.MATMOD(/2) MN3 =IMODE1.INFMOD(/1) NPARMO=0 nobmod=0 SEGINI IMODEL conmod(17:24)=' ' IMAMOD=IPOGEO NEFMOD=IMODE1.NEFMOD CONMOD=IMODE1.CONMOD IPDPGE=IMODE1.IPDPGE * * CREATION D'UN TABLEAU DE CORRESPONDANCE LE IMAMOD DU * MMODEL (IPMODL) ET DU IMAMOD DU NVX MMODEL QUE L'ON CREE * (UTILISE DANS LE KOMCHA POUR LE MCHAML DE CARATERISTIQUE * POUR LES COQ6 ET COQ8) * IF (NEFMOD.EQ.41.OR.NEFMOD.EQ.56) THEN IF (JPMAIL.EQ.0) SEGINI JPMAIL MAIL1(ISOUS)=ITGEOM MAIL2(ISOUS)=IPOGEO ENDIF DO 47 I=1,MN3 INFMOD(I)=IMODE1.INFMOD(I) 47 CONTINUE CONMOD=IMODE1.CONMOD DO 48 I=1,NFOR FORMOD(I)=IMODE1.FORMOD(I) 48 CONTINUE DO 49 I=1,NMAT MATMOD(I)=IMODE1.MATMOD(I) 49 CONTINUE KMODEL(N1)=IMODEL lzero=0 call inomid(imodel,' ',iret,lzero,lzero,lzero,lzero) call prquoi(imodel) SEGDES IMODEL ELSE * * LE CHPOINT N'ADHERE PAS A CETTE ZONE * IRRT=IRRT+1 ENDIF SEGDES IMODE1 50 CONTINUE SEGDES MMODE1 SEGDES MMODEL * IF (NSOUPO.GT.1) THEN MELEME=IPGEOM SEGSUP MELEME ENDIF * IF (IRRT.EQ.NSOUS1) THEN * * L'OBJET MAILLAGE ET LE CHPOINT SONT INCOMPATIBLES * MOTERR(1:8)='MAILLAGE' MOTERR(9:16)='CHPOINT' CALL ERREUR(135) MMODEL=IPMOD SEGSUP MMODEL IF (JPMAIL.NE.0) SEGSUP JPMAIL RETURN ENDIF IPMODI=IPMOD ELSE IPMODI=IPMODL IFLAG=1 ENDIF * * *-------EN 3D ET DANS LE CAS OU NORM N'A PAS ETE INDIQUE * ON CHARGE PRORIE DE REORIENTER LES ELEMENTS * IF (IDIM.EQ.3.AND.JMLU.EQ.0) THEN MMODE1=IPMODI SEGACT MMODE1 NSOUS=MMODE1.KMODEL(/1) N1=NSOUS SEGINI MMODEL IPMOD=MMODEL NBELEM=0 NBNN=0 NBREF=0 NBSOUS=NSOUS SEGINI MELEME DO 9 ISOUS=1,NSOUS IMODEL=MMODE1.KMODEL(ISOUS) SEGACT IMODEL LISOUS(ISOUS)=IMAMOD SEGDES IMODEL 9 CONTINUE * * MAILLAGE A REORIENTER * CALL ECROBJ('MAILLAGE',MELEME) * * ORIENTATION PRORIE LIT LES DONNEES QUI LE CONCERNE * CALL PRORIE * * MAILLAGE REORIENTE * CALL LIROBJ('MAILLAGE',MELEME,1,IRETOU) IF (IERR.NE.0) THEN SEGSUP MMODEL IF (IFLAG.EQ.0) CALL DTMODL(IPMODI) IF (JPMAIL.NE.0) SEGSUP JPMAIL RETURN ENDIF SEGACT MELEME DO 10 ISOUS=1,NSOUS IMODE1=MMODE1.KMODEL(ISOUS) SEGACT IMODE1 NFOR=IMODE1.FORMOD(/2) NMAT=IMODE1.MATMOD(/2) MN3 =IMODE1.INFMOD(/1) NPARMO=0 nobmod=0 SEGINI IMODEL conmod(17:24)=' ' KMODEL(ISOUS)=IMODEL * * IMAMOD REORIENTE * IMAMOD=LISOUS(ISOUS) NEFMOD=IMODE1.NEFMOD CONMOD=IMODE1.CONMOD IPDPGE=IMODE1.IPDPGE * * MISE A JOUR DU TABLEAU DE CORRESONDANCE DES IMAMOD * IF (NEFMOD.EQ.41.OR.NEFMOD.EQ.56) THEN IF (JPMAIL.EQ.0) THEN NSOUS1=NSOUS SEGINI JPMAIL ENDIF IF (IFLAG.EQ.1) MAIL1(ISOUS)=IMODE1.IMAMOD MAIL2(ISOUS)=IMAMOD ENDIF DO 3 I=1,MN3 INFMOD(I)=IMODE1.INFMOD(I) 3 CONTINUE CONMOD=IMODE1.CONMOD DO 1 I=1,NFOR FORMOD(I)=IMODE1.FORMOD(I) 1 CONTINUE DO 2 I=1,NMAT MATMOD(I)=IMODE1.MATMOD(I) 2 CONTINUE SEGDES IMODEL IF (IFLAG.EQ.1) THEN SEGDES IMODE1 ELSE SEGSUP IMODE1 ENDIF lzer=0 call inomid(imodel,' ',iret,lzer,lzer,lzer,lzer) call prquoi(imodel ) SEGDES IMODEL 10 CONTINUE SEGDES MMODEL IF (IFLAG.EQ.1) THEN SEGDES MMODE1 ELSE SEGSUP MMODE1 ENDIF IFLAG=0 ELSE IPMOD=IPMODI ENDIF * * EN 2D ET EN 3D , ON VERIFIE QUE 2 ELEMENTS ADJACENTS * ONT LA MEME ORIENTATION * MMODEL=IPMOD SEGACT MMODEL DO 11 ISOUS=1,KMODEL(/1) IMODEL=KMODEL(ISOUS) SEGACT IMODEL IF (ISOUS.GT.1) THEN IPTGEO=IMAMOD ltelq=.false. CALL FUSE(IGEOM,IPTGEO,IPPT,ltelq) IGEOM=IPPT ELSE IGEOM=IMAMOD ENDIF SEGDES IMODEL 11 CONTINUE CALL ECROBJ('MAILLAGE',IGEOM) CALL VERSEN CALL LIROBJ('MAILLAGE',IGEOM,1,IRETOU) IF (IERR.NE.0) THEN IF (IFLAG.EQ.0) CALL DTMODL(IPMOD) IF (JPMAIL.NE.0) SEGSUP JPMAIL RETURN ENDIF * IF (KMODEL(/1).GT.1) THEN MELEME=IGEOM SEGSUP MELEME ENDIF SEGDES MMODEL * * ON TRANSFORME LE CHPOINT DE PRESSION EN CHELEM * IF (IPCHE1.EQ.0) THEN CALL ZEROP(IPMOD,MOT,IPCH1) IF (IERR.NE.0) RETURN MCHEL1=IPCH1 SEGACT MCHEL1 NSOUS=MCHEL1.ICHAML(/1) DO 12 ISOUS=1,NSOUS MCHAM1=MCHEL1.ICHAML(ISOUS) SEGACT MCHAM1 MELVA1=MCHAM1.IELVAL(1) SEGACT MELVA1*MOD N1PTEL=MELVA1.VELCHE(/1) N1EL =MELVA1.VELCHE(/2) DO 13 IGAU=1,N1PTEL DO 13 IB=1,N1EL MELVA1.VELCHE(IGAU,IB)=P 13 CONTINUE SEGDES MELVA1 SEGDES MCHAM1 12 CONTINUE SEGDES MCHEL1 ELSE * * On met le MCHAML aux noeuds * CALL CHAME1(0,IPMOD,IPCHE,' ',IPCH1,1) IF (IERR.NE.0) THEN IF (IFLAG.EQ.0) CALL DTMODL(IPMOD) IF (JPMAIL.NE.0) SEGSUP JPMAIL RETURN ENDIF ENDIF * * ACTIVATION DU MODEL * MMODEL=IPMOD SEGACT MMODEL NSOUS=KMODEL(/1) DO 100 ISOUS=1,NSOUS * * INITIALISATION DU CHELEM ELEMENTAIRE DES FORCES NODALES * N1=1 L1=6 N3=5 SEGINI MCHELM IPCHEL=MCHELM TITCHE='FORCES' IFOCHE=IFOUR * * ON RECUPERE L INFORMATION GENERALE * IMODEL=KMODEL(ISOUS) SEGACT IMODEL IPMAIL=IMAMOD CONM =CONMOD IMACHE(1)=IPMAIL * * TRAITEMENT DU MODEL * MELE=NEFMOD MELEME=IMAMOD * * INFORMATION SUR L ELEMENT FINI * * CALL ELQUOI (MELE,0,3,IPINF,IMODEL) IF (IERR.NE.0) THEN SEGDES IMODEL,MMODEL SEGSUP MCHELM IF (IFLAG.EQ.0) CALL DTMODL (IPMOD) IF (JPMAIL.NE.0) SEGSUP JPMAIL CALL DTCHAM(IPCH1) RETURN ENDIF * * INFO=IPINF MFR =INFELE(13) * IPTINT=INFELE(11) IPTINT=infmod(5) IPTNOE=INFMOD(8) * * CREATION DU TABLEAU INFO * CALL IDENT (IPMAIL,CONM,IPCH1,0,INFOS,IRTD) IF (IRTD.EQ.0) THEN SEGDES IMODEL,MMODEL SEGSUP MCHELM IF (IFLAG.EQ.0) CALL DTMODL (IPMOD) IF (JPMAIL.NE.0) SEGSUP JPMAIL CALL DTCHAM(IPCH1) RETURN ENDIF * INFCHE(1,1)=0 INFCHE(1,2)=0 INFCHE(1,3)=NHRM INFCHE(1,4)=IPTINT INFCHE(1,5)=0 * SEGACT MELEME NBELEM=NUM(/2) NBNN=NUM(/1) IPPORE=0 IF(MFR.EQ.33) IPPORE=NBNN * MINTE=IPTINT SEGACT,MINTE * * RECHERCHE DU MELVAL DU CHAMELEM DE PRESSION * NCARA=0 NCARF=0 MOCARA=0 NFOR=0 MOFORC=0 * NBROBL=1 NBRFAC=0 SEGINI NOMID MOSCAL=NOMID LESOBL(1)='SCAL' * NBTYPE=1 SEGINI NOTYPE MOTYPE=NOTYPE TYPE(1)='REAL*8' * CALL KOMCHA(IPCH1,IPMAIL,CONM,MOSCAL,MOTYPE,1,INFOS,3,IVASCA) SEGSUP NOTYPE IF (IERR.NE.0) GOTO 9990 SEGDES NOMID MPTVAL=IVASCA IPTVPR=IVAL(1) * * RECHERCHE DES NOMS DE COMPOSANTES * if(lnomid(2).ne.0) then nomid=lnomid(2) segact nomid moforc=nomid nfor=lesobl(/2) lsupfo=.false. nfac=0 else lsupfo=.true. CALL IDFORC (MFR,IFOUR,MOFORC,NFOR,NFAC) endif NCOMP=NFOR nomid=moforc segact nomid IF(IFOUR.EQ.-3) NCOMP=NFOR-3 * * CREATION DU MCHAML DE LA SOUS ZONE * IF (MELE.EQ.27.OR.MELE.EQ.28.OR.MELE.EQ.45 1 .OR.MELE.EQ.93) THEN N1PTEL=3 ELSE IF (MELE.EQ.44) THEN N1PTEL=2 ELSE IF (MELE.EQ.49.OR.MELE.EQ.41.OR.MELE.EQ.56) THEN N1PTEL=NBNN ELSE * * ERREUR L ELEMENT N EST PAS ENCORE IMPLEMENTE * MOTERR(1:4)=NOMTP(MELE) MOTERR(5:12)='FPCOQU ' CALL ERREUR(86) GOTO 9990 ENDIF * N1EL=NBELEM N2PTEL=0 N2EL =0 N2=NCOMP SEGINI MCHAML ICHAML(1)=MCHAML NS=1 NCOSOU=NCOMP SEGINI MPTVAL IVAFOR=MPTVAL NOMID=MOFORC SEGACT NOMID DO 4 ICOMP=1,NCOMP NOMCHE(ICOMP)=LESOBL(ICOMP) TYPCHE(ICOMP)='REAL*8' SEGINI MELVAL IELVAL(ICOMP)=MELVAL IVAL(ICOMP)=MELVAL 4 CONTINUE SEGDES NOMID *_______________________________________________________________________ * * CALCUL DES FORCES NODALES EQUIVALENTES * DEBRANCHEMENT SUIVANT LE TYPE DES ELEMENTS *_______________________________________________________________________ * IF (MELE.EQ.27.OR.MELE.EQ.28.OR.MELE.EQ.45 1 .OR.MELE.EQ.93) THEN * * ELEMENTS COQ3 , DKT OU DKTC * --------------------------- CALL FPCO3D(IPTVPR,IPMAIL,IVAFOR) ELSE IF (MELE.EQ.44) THEN * * ELEMENT COQ2 * ------------ * * TRAITEMENT DU CHAMP DE CARACTERISTIQUES * IF (IFOUR.EQ.-2.AND.IND.EQ.0) THEN CALL LIROBJ('MCHAML',IPCHE2,0,IRT3) IND=1 IF (IERR.NE.0) GOTO 9990 IF (IPCHE2.NE.0) THEN * * Verification du lieu support du MCHAML de caracteristique * CALL QUESUP(IPMODL,IPCHE2,3,1,ISUP,IRETCA) IF (ISUP.GT.1) GOTO 9990 * * CREATION DU TABLEAU INFO * CALL IDENT (IPMAIL,CONM,IPCHE2,0,INFOS,IRTD) IF (IRTD.EQ.0) GOTO 9990 * NCARA=0 NCARF=0 NBROBL=0 NBRFAC=1 SEGINI NOMID MOCARA=NOMID LESFAC(1)='DIM3' * NBTYPE=1 SEGINI NOTYPE MOTYPE=NOTYPE TYPE(1)='REAL*8' * CALL KOMCHA(IPCHE2,IPMAIL,CONM,MOCARA,MOTYPE,0, + INFOS,3,IVACAR) SEGSUP NOTYPE IF (IERR.NE.0) GOTO 9990 NCARA=NBROBL NCARF=NBRFAC NCARR=NCARA+NCARF * IF (ISUP.EQ.1) THEN CALL VALCHE(IVACAR,NCARR,IPTINT,IPPORE) ENDIF * SEGDES NOMID ENDIF ENDIF CALL FPCO2D (IPTVPR,IPMAIL,IVAFOR,IVACAR) ELSE IF (MELE.EQ.49) THEN * * ELEMENTS COQ4 * ------------- CALL FPCOQ4(IPTVPR,IPMAIL,IPTINT,IVAFOR) ELSE IF (MELE.EQ.41.OR.MELE.EQ.56) THEN * * ELEMENTS COQ6 OU COQ8 * --------------------- IF(IPCHE2.EQ.0) THEN CALL LIROBJ('MCHAML',IPCHE2,1,IRT3) IF (IRT3.EQ.0) GOTO 9990 * * Verification du lieu support du MCHAML de caracteristique * CALL QUESUP(IPMODL,IPCHE2,3,0,ISUP,IRETCA) IF (ISUP.GT.1) GOTO 9990 ENDIF *____________________________________________________________________ * * TRAITEMENT DES CHAMPS DE CARACTERISTIQUES * CARACTERISTIQUES POUR LES COQ8 ET COQ6 *____________________________________________________________________ * IVACAR=0 NCARA=0 NCARF=0 NBROBL=1 NBRFAC=0 SEGINI NOMID MOCARA=NOMID LESOBL(1)='EPAI' IF (IFLAG.EQ.0) THEN * * ON RECUPERE LE IMAMOD DU MMODEL D'ORIGINE POUR QUE LE IPMAIL * DONNE CORRESPONDE A CELUI DE IPCHE21 * DO 60 KISOUS=1,NSOUS1 IF (IPMAIL.EQ.MAIL2(KISOUS)) THEN IPMAI1=MAIL1(KISOUS) GOTO 61 ENDIF 60 CONTINUE * * NE DOIT NORMALEMENT JAMAIS SE PRODUIRE * CALL ERREUR (472) GOTO 9990 ELSE IPMAI1=IPMAIL ENDIF 61 CONTINUE * NBTYPE=1 SEGINI NOTYPE MOTYPE=NOTYPE TYPE(1)='REAL*8' * CALL KOMCHA(IPCHE2,IPMAI1,CONM,MOCARA,MOTYPE,1,INFOS,3,IVACAR) SEGSUP NOTYPE IF (IERR.NE.0) GOTO 9990 NCARA=NBROBL NCARF=NBRFAC NCARR=NCARA+NCARF * IF (ISUP.EQ.1) THEN CALL VALCHE(IVACAR,NCARR,IPTINT,IPPORE) ENDIF * SEGDES NOMID CALL FPCOQ8(IPTVPR,IPMAIL,IPTINT,IVACAR,IPTNOE,IVAFOR) ELSE * * ERREUR L ELEMENT N EST PAS ENCORE IMPLEMENTE * MOTERR(1:4)=NOMTP(MELE) MOTERR(5:12)='FPCOQU' CALL ERREUR(86) GOTO 9990 ENDIF * * ON TRANSFORME LE CHAM/ELEM EN CHAM/POIN * CALL CHAMPO(IPCHEL,0,IPCHPO,IRET) CALL DTCHAM(IPCHEL) IF (IRET.EQ.0) GOTO 9990 * IF (ISOUS.GT.1) THEN CALL ADCHPO(IPCHPO,IPTFP,IRET,1D0,1D0) CALL DTCHPO(IPCHPO) CALL DTCHPO(IPTFP) IF (IRET.EQ.0) GOTO 9990 IPTFP=IRET ELSE IPTFP=IPCHPO ENDIF * SEGDES IMODEL * IF (ISUP.EQ.1) THEN CALL DTMVAL(IVACAR,3) ELSE CALL DTMVAL(IVACAR,1) ENDIF * MPTVAL=IVASCA MELVAL=IVAL(1) SEGDES MELVAL SEGSUP MPTVAL * MPTVAL=IVAFOR SEGSUP MPTVAL * NOMID=MOFORC if(lsupfo)SEGSUP NOMID NOMID=MOSCAL SEGSUP NOMID SEGDES,MINTE SEGDES MELEME NOMID=MOCARA IF (MOCARA.NE.0) SEGSUP NOMID * 100 CONTINUE IRET=1 IF (JPMAIL.NE.0) SEGSUP JPMAIL CALL DTCHAM(IPCH1) SEGDES MMODEL IF (IFLAG.EQ.0) CALL DTMODL(IPMOD) RETURN * * * 9990 CONTINUE IRET=0 SEGSUP MCHELM * * ERREUR DANS UNE SOUS ZONE, DESACTIVATION ET RETOUR * IF (ISUP.EQ.1) THEN CALL DTMVAL(IVACAR,3) ELSE CALL DTMVAL(IVACAR,1) ENDIF * CALL DTMVAL(IVAFOR,1) * SEGDES,MINTE SEGDES MELEME * MPTVAL=IVASCA MELVAL=IVAL(1) SEGDES MELVAL SEGSUP MPTVAL * NOMID=MOCARA IF (MOCARA.NE.0) SEGSUP NOMID NOMID=MOFORC IF (lsupfo.and.MOFORC.NE.0) SEGSUP NOMID * SEGDES IMODEL SEGDES MMODEL * IF (IFLAG.EQ.0) CALL DTMODL(IPMOD) IF (JPMAIL.NE.0) SEGSUP JPMAIL * CALL DTCHAM(IPCH1) * RETURN END