C FPCOQU SOURCE MB234859 25/09/08 21:15:27 12358 SUBROUTINE FPCOQU(P,IPCHE1,IPCHM1,IPMODL,JMLU,IPTFP,IRET) *_____________________________________________________________________ * * 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 * IPCHM1 CHAMELEM 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 *_____________________________________________________________________ IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) -INC PPARAM -INC CCOPTIO -INC CCHAMP -INC SMCOORD -INC SMELEME -INC SMMODEL -INC SMCHAML -INC SMCHPOI -INC SMINTE -INC TMPTVAL SEGMENT NOTYPE CHARACTER*16 TYPE(NBTYPE) 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 ltelq INTEGER ISUPCA DATA MOT/'RIGIDITE'/ IRET = 0 IGEOM= 0 lzero = 0 nbtype = 1 SEGINI,notype notype.TYPE(1) = 'REAL*8 ' MOTYR8 = notype nbrobl = 1 nbrfac = 0 SEGINI,nomid nomid.LESOBL(1) = 'SCAL ' MOSCAL = nomid NHRM=NIFOUR IFLAG=0 IVACAR=0 JPMAIL=0 * CHAMP PAR ELEMENT des CARACTERISTIQUES IPCHE2 = 0 ISUPCA = 0 CALL LIROBJ('MCHAML ',IPCHE2,0,IRT3) IF (IERR.NE.0) RETURN * 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.OR.IPCHM1.NE.0) THEN * * ON CREE LE MMODEL S'ACCROCHANT AU CHPOINT * * ON CREE L OBJET MAILLAGE CONTENANT TOUS LES POINTS DU CHPOINT * IF (IPCHE1.NE.0) THEN CALL NOMCOM(IPCHE1,'SCAL',IPCHE,IRETOU) IF (IERR.NE.0) RETURN 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 1140 CONTINUE * * ON CREE L OBJET MAILLAGE CONTENANT TOUS LES POINTS DU CHAMELEM * ELSE CALL ECROBJ('MCHAML ',IPCHM1) CALL ECRCHA('SCAL') CALL NOMC IF (IERR.NE.0) RETURN CALL LIROBJ('MCHAML ',IPCHE,1,IRETOU) IF (IERR.NE.0) RETURN MCHEL2=IPCHE SEGACT MCHEL2 DO 1150 I=1,MCHEL2.IMACHE(/1) IMTMP=MCHEL2.IMACHE(I) IF (I.GT.1) THEN ltelq=.false. CALL FUSE (IPGEOM,IMTMP,IPPT,ltelq) IPGEOM = IPPT ELSE IPGEOM = IMTMP ENDIF 1150 CONTINUE ENDIF IF (IERR.NE.0) RETURN N1=0 SEGINI MMODEL IPMOD=MMODEL MMODE1=IPMODL NSOUS1=MMODE1.KMODEL(/1) * BOUCLE SUR LES SOUS ZONE GEOMETRIQUES ELEMENTAIRES IRRT=0 DO 50 ISOUS=1,NSOUS1 IMODE1=MMODE1.KMODEL(ISOUS) 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 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(1: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 call inomid(imodel,lzero,lzero,lzero,lzero) call prquoi(imodel) ELSE * * LE CHPOINT OU CHAMELEM N'ADHERE PAS A CETTE ZONE * IRRT=IRRT+1 ENDIF 50 CONTINUE * IF (NSOUPO.GT.1) THEN MELEME=IPGEOM SEGSUP MELEME ENDIF * IF (IRRT.EQ.NSOUS1) THEN * * L'OBJET MAILLAGE ET LE CHPOINT OU CHAMELEM SONT INCOMPATIBLES * MOTERR(1:8)='MAILLAGE' IF (IPCHE1.NE.0) THEN MOTERR(9:16)='CHPOINT' ELSE MOTERR(9:16)='CHAMELEM' ENDIF 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 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) LISOUS(ISOUS)=IMAMOD 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(1: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 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 DO 3 I=1,MN3 INFMOD(I)=IMODE1.INFMOD(I) 3 CONTINUE IF (IFLAG.NE.1) THEN SEGSUP IMODE1 ENDIF call inomid(imodel,lzero,lzero,lzero,lzero) call prquoi(imodel) 10 CONTINUE IF (IFLAG.NE.1) SEGSUP MMODE1 IFLAG=0 ELSE IPMOD=IPMODI ENDIF * * EN 2D ET EN 3D , ON VERIFIE QUE 2 ELEMENTS ADJACENTS * ONT LA MEME ORIENTATION * MMODEL=IPMOD DO 11 ISOUS=1,KMODEL(/1) IMODEL=KMODEL(ISOUS) IF (ISOUS.GT.1) THEN IPTGEO=IMAMOD ltelq=.false. CALL FUSE(IGEOM,IPTGEO,IPPT,ltelq) IGEOM=IPPT ELSE IGEOM=IMAMOD ENDIF 11 CONTINUE CALL ECROBJ('MAILLAGE',IGEOM) CALL VERSEN CALL LIROBJ('MAILLAGE',IGEOM,1,IRETOU) IF (IERR.NE.0) GOTO 9990 IF (KMODEL(/1).GT.1) THEN MELEME=IGEOM SEGSUP MELEME ENDIF * * ON TRANSFORME LE CHPOINT DE PRESSION EN CHELEM * IF (IPCHE1.EQ.0.AND.IPCHM1.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 IB=1,N1EL DO IGAU=1,N1PTEL MELVA1.VELCHE(IGAU,IB)=P ENDDO ENDDO 12 CONTINUE ELSE IF (IPCHE1.NE.0) THEN * * On transforme le CHPOINT en MCHAML aux pts de Gauss pour la rigidite * CALL CHAME1(0,IPMOD,IPCHE,' ',IPCH1,3) IF (IERR.NE.0) GOTO 9990 ELSE * * On change eventuellement le support du MCHAML * CALL QUESUP(0,IPCHE,0,0,ISUP1,ISUP2) IPCH1=IPCHE ENDIF * Verification du lieu support du MCHAML de caracteristiques IF (IPCHE2.NE.0) THEN CALL QUESUP(IPMODL,IPCHE2,3,1,ISUPCA,iretca) IF (ISUPCA.GT.1) GOTO 9990 ENDIF * ACTIVATION DU MODEL * MMODEL=IPMOD NSOUS=KMODEL(/1) DO 100 ISOUS=1,NSOUS IVAFOR=0 IVASCA=0 IVACAR=0 MOCARA = 0 * * TRAITEMENT DU MODEL * IMODEL=KMODEL(ISOUS) * * ON RECUPERE L INFORMATION GENERALE * IPMAIL = IMAMOD CONM = CONMOD MELE = NEFMOD MELEME = IPMAIL NBELEM = meleme.NUM(/2) NBNN = meleme.NUM(/1) * * INFORMATION SUR L ELEMENT FINI * MFR = imodel.INFELE(13) IPTINT = imodel.INFMOD(5) IPTNOE = imodel.INFMOD(3) IPPORE=0 IF (MFR.EQ.33) IPPORE=NBNN * * RECHERCHE DU MELVAL DU CHAMELEM DE PRESSION * * CREATION DU TABLEAU INFO CALL IDENT(IPMAIL,CONM,IPCH1,0,INFOS,IRTD) IF (IRTD.EQ.0) GOTO 910 * CALL KOMCHA(IPCH1,IPMAIL,CONM,MOSCAL,MOTYR8,1,INFOS,3,IVASCA) IF (IERR.NE.0) GOTO 910 MPTVAL = IVASCA IPTVPR = IVAL(1) * * CHANGEMENT EVENTUEL DU SUPPORT DANS LE CAS OU UN MCHAML A ETE FOURNI * IF (IPCHM1.NE.0) THEN IF (ISUP2.EQ.4) THEN CALL ERREUR(609) GOTO 910 ELSE IF (ISUP2.EQ.1) THEN IVPRES = IPTVPR CALL VALMEL(IVPRES,IPTINT,IPTVPR) ENDIF ENDIF * * RECHERCHE DES NOMS DE COMPOSANTES * nomid = imodel.LNOMID(2) if (nomid.ne.0) then MOFORC=nomid nfor=lesobl(/2) nfac=0 else CALL IDFORC(MFR,IFOUR,MOFORC,NFOR,NFAC) write(ioimp,*) 'FPCOQU : MOFORC = 0' call erreur(5) endif NCOMP=NFOR 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.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 910 ENDIF * N1EL=NBELEM N2PTEL=0 N2EL =0 N2=NCOMP SEGINI MCHAML NSR=1 NCOSOR=NCOMP SEGINI MPTVAL IVAFOR=MPTVAL NOMID=MOFORC DO 4 ICOMP=1,NCOMP NOMCHE(ICOMP)=LESOBL(ICOMP) TYPCHE(ICOMP)='REAL*8' SEGINI MELVAL IELVAL(ICOMP)=MELVAL IVAL(ICOMP)=MELVAL 4 CONTINUE *_______________________________________________________________________ * * 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.IPCHE2.NE.0) THEN * * CREATION DU TABLEAU INFO * CALL IDENT(IPMAIL,CONM,IPCHE2,0,INFOS,IRTD) IF (IRTD.EQ.0) GOTO 910 NBROBL=0 NBRFAC=1 SEGINI NOMID LESFAC(1)='DIM3' NCARA=NBROBL NCARF=NBRFAC NCARR=NCARA+NCARF MOCARA = NOMID CALL KOMCHA(IPCHE2,IPMAIL,CONM,MOCARA,MOTYR8,0, + INFOS,3,IVACAR) IF (IERR.NE.0) GOTO 910 * IF (ISUP.EQ.1) THEN CALL VALCHE(IVACAR,NCARR,IPTINT,IPPORE,MOCARA,MELE) ENDIF ENDIF * CALL FPCO2D (IPTVPR,IPMAIL,IVAFOR,IVACAR) * * ELEMENTS COQ4 * ------------- ELSE IF (MELE.EQ.49) THEN CALL FPCOQ4(IPTVPR,IPMAIL,IPTINT,IVAFOR) * * ELEMENTS COQ6 OU COQ8 * --------------------- ELSE IF (MELE.EQ.41.OR.MELE.EQ.56) THEN IF (IPCHE2.EQ.0) THEN * Message a affiner write(ioimp,*) 'Manque CARACTERISTIQUES COQ6&COQ8' CALL ERREUR(21) GOTO 910 ENDIF *____________________________________________________________________ * * TRAITEMENT DES CHAMPS DE CARACTERISTIQUES * CARACTERISTIQUES POUR LES COQ8 ET COQ6 *____________________________________________________________________ * NBROBL=1 NBRFAC=0 SEGINI NOMID LESOBL(1)='EPAI' NCARA=NBROBL NCARF=NBRFAC NCARR=NCARA+NCARF MOCARA=NOMID 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 910 61 CONTINUE ELSE IPMAI1=IPMAIL ENDIF CALL KOMCHA(IPCHE2,IPMAI1,CONM,MOCARA,MOTYR8,1,INFOS,3,IVACAR) IF (IERR.NE.0) GOTO 910 IF (ISUPCA.EQ.1) THEN CALL VALCHE(IVACAR,NCARR,IPTINT,IPPORE,MOCARA,MELE) ENDIF 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 910 ENDIF * * INITIALISATION DU CHELEM ELEMENTAIRE DES FORCES NODALES * N1=1 L1=6 N3=6 SEGINI,MCHELM IPCHEL=MCHELM mchelm.TITCHE = 'FORCES' mchelm.IFOCHE = IFOUR mchelm.IMACHE(1) = IPMAIL mchelm.CONCHE(1) = CONM mchelm.ICHAML(1) = MCHAML mchelm.INFCHE(1,1) = 0 mchelm.INFCHE(1,2) = 0 mchelm.INFCHE(1,3) = NHRM mchelm.INFCHE(1,4) = IPTINT mchelm.INFCHE(1,5) = 0 mchelm.INFCHE(1,6) = 3 * * ON TRANSFORME LE CHAM/ELEM EN CHAM/POIN * CALL CHAMPO(IPCHEL,0,IPCHPO,IRET) CALL DTCHAM(IPCHEL) IF (IRET.EQ.0) GOTO 910 IF (ISOUS.GT.1) THEN CALL ADCHPO(IPCHPO,IPTFP,IRET,1D0,1D0) CALL DTCHPO(IPCHPO) CALL DTCHPO(IPTFP) IF (IRET.EQ.0) GOTO 910 IPTFP=IRET ELSE IPTFP=IPCHPO ENDIF ISOK = 1 910 CONTINUE IF (ISUPCA.EQ.1) THEN CALL DTMVAL(IVACAR,3) ELSE CALL DTMVAL(IVACAR,1) ENDIF MPTVAL = IVASCA IF (mptval.NE.0) SEGSUP,MPTVAL MPTVAL = IVAFOR IF (mptval.NE.0) SEGSUP,MPTVAL NOMID = MOCARA IF (nomid.NE.0) SEGSUP,NOMID * ERREUR DANS UNE SOUS ZONE, DESACTIVATION ET RETOUR IF (ISOK .NE. 1) GOTO 9997 100 CONTINUE IRET = 1 * * FIN : 9997 CONTINUE notype = MOTYR8 SEGSUP,notype nomid = MOSCAL SEGSUP,nomid 9990 CONTINUE IF (IFLAG.EQ.0) CALL DTMODL(IPMOD) IF (JPMAIL.NE.0) SEGSUP,JPMAIL RETURN END