fpcoqu
C FPCOQU SOURCE PV 21/12/18 07:15:03 11240 *_____________________________________________________________________ * * 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 * * * 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 PPARAM -INC CCOPTIO -INC CCHAMP -INC SMCOORD -INC SMELEME -INC SMMODEL -INC SMCHAML -INC SMCHPOI -INC SMINTE * logical ltelq INTEGER ISUP 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/'RIGIDITE'/ * lsupfo=.false. ISUP=0 IRET = 0 IGEOM= 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.OR.IPCHM1.NE.0) THEN * * ON CREE LE MMODEL S'ACCROCHANT AU CHPOINT * IF (IPCHE1.NE.0) THEN ELSE CALL NOMC ENDIF IF (IERR.NE.0) RETURN IF (IPCHE1.NE.0) THEN * * ON CREE L OBJET MAILLAGE CONTENANT TOUS LES POINTS 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. IPGEOM = IPPT ENDIF 1140 CONTINUE ELSE * * ON CREE L OBJET MAILLAGE CONTENANT TOUS LES POINTS DU CHAMELEM * MCHEL2=IPCHE SEGACT MCHEL2 DO 1150 I=1,MCHEL2.IMACHE(/1) IMTMP=MCHEL2.IMACHE(I) IF (I.GT.1) THEN ltelq=.false. IPGEOM = IPPT ELSE IPGEOM = IMTMP ENDIF 1150 CONTINUE ENDIF IF (IERR.NE.0) RETURN * 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 IF (IRR.EQ.0) THEN * * ON A VERIFIER L ADHERENCE DU CHPOINT A CE MAILLAGE * 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(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 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 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 9 CONTINUE * * MAILLAGE A REORIENTER * * * ORIENTATION PRORIE LIT LES DONNEES QUI LE CONCERNE * CALL PRORIE * * MAILLAGE REORIENTE * IF (IERR.NE.0) THEN SEGSUP MMODEL 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 IF (IFLAG.NE.1) THEN SEGSUP IMODE1 ENDIF lzer=0 10 CONTINUE IF (IFLAG.NE.1) THEN 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. IGEOM=IPPT ELSE IGEOM=IMAMOD ENDIF 11 CONTINUE CALL VERSEN IF (IERR.NE.0) THEN IF (JPMAIL.NE.0) SEGSUP JPMAIL RETURN ENDIF * 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 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 12 CONTINUE ELSE IF (IPCHE1.NE.0) THEN * * On transforme le CHPOINT en MCHAML aux pts de Gauss pour la rigidite * IF (IERR.NE.0) THEN IF (JPMAIL.NE.0) SEGSUP JPMAIL RETURN ENDIF ELSE * * On change eventuellement le support du MCHAML * IPCH1=IPCHE 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 SEGSUP MCHELM IF (JPMAIL.NE.0) SEGSUP JPMAIL RETURN ENDIF * * INFO=IPINF MFR =INFELE(13) * IPTINT=INFELE(11) IPTINT=infmod(5) IPTNOE=INFMOD(8) * * CREATION DU TABLEAU INFO * IF (IRTD.EQ.0) THEN SEGSUP MCHELM IF (JPMAIL.NE.0) SEGSUP JPMAIL 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' * SEGSUP NOTYPE IF (IERR.NE.0) GOTO 9990 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.NE.3.AND.ISUP2.NE.5.AND.ISUP2.NE.2) THEN IF (ISUP2.EQ.4) THEN GOTO 9997 ELSE IF (ISUP2.EQ.1) THEN IVPRES = IPTVPR ENDIF ENDIF ENDIF * * * 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. 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.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 ' 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 *_______________________________________________________________________ * * 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 * --------------------------- ELSE IF (MELE.EQ.44) THEN * * ELEMENT COQ2 * ------------ * * TRAITEMENT DU CHAMP DE CARACTERISTIQUES * IF (IFOUR.EQ.-2.AND.IND.EQ.0) THEN IND=1 IF (IERR.NE.0) GOTO 9990 IF (IPCHE2.NE.0) THEN * * Verification du lieu support du MCHAML de caracteristique * IF (ISUP.GT.1) GOTO 9990 * * CREATION DU TABLEAU INFO * 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' * + INFOS,3,IVACAR) SEGSUP NOTYPE IF (IERR.NE.0) GOTO 9990 NCARA=NBROBL NCARF=NBRFAC NCARR=NCARA+NCARF * IF (ISUP.EQ.1) THEN ENDIF ENDIF ENDIF * ELSE IF (MELE.EQ.49) THEN * * ELEMENTS COQ4 * ------------- * ELSE IF (MELE.EQ.41.OR.MELE.EQ.56) THEN * * ELEMENTS COQ6 OU COQ8 * --------------------- IF(IPCHE2.EQ.0) THEN IF (IRT3.EQ.0) GOTO 9990 * * Verification du lieu support du MCHAML de caracteristique * 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 * GOTO 9990 ELSE IPMAI1=IPMAIL ENDIF 61 CONTINUE * NBTYPE=1 SEGINI NOTYPE MOTYPE=NOTYPE TYPE(1)='REAL*8' * SEGSUP NOTYPE IF (IERR.NE.0) GOTO 9990 NCARA=NBROBL NCARF=NBRFAC NCARR=NCARA+NCARF * IF (ISUP.EQ.1) THEN ENDIF * ELSE * * ERREUR L ELEMENT N EST PAS ENCORE IMPLEMENTE * MOTERR(1:4)=NOMTP(MELE) MOTERR(5:12)='FPCOQU' GOTO 9990 ENDIF * * ON TRANSFORME LE CHAM/ELEM EN CHAM/POIN * IF (IRET.EQ.0) GOTO 9990 * IF (ISOUS.GT.1) THEN IF (IRET.EQ.0) GOTO 9990 IPTFP=IRET ELSE IPTFP=IPCHPO ENDIF * IF (ISUP.EQ.1) THEN ELSE ENDIF * MPTVAL=IVASCA MELVAL=IVAL(1) SEGSUP MPTVAL * MPTVAL=IVAFOR SEGSUP MPTVAL * NOMID=MOFORC if(lsupfo)SEGSUP NOMID NOMID=MOSCAL SEGSUP NOMID NOMID=MOCARA IF (MOCARA.NE.0) SEGSUP NOMID * 100 CONTINUE IRET=1 IF (JPMAIL.NE.0) SEGSUP JPMAIL RETURN * * * 9990 CONTINUE IRET=0 SEGSUP MCHELM * * ERREUR DANS UNE SOUS ZONE, DESACTIVATION ET RETOUR * IF (ISUP.EQ.1) THEN ELSE ENDIF * * MPTVAL=IVASCA MELVAL=IVAL(1) SEGSUP MPTVAL * NOMID=MOCARA IF (MOCARA.NE.0) SEGSUP NOMID NOMID=MOFORC IF (lsupfo.and.MOFORC.NE.0) SEGSUP NOMID * 9997 CONTINUE * IF (JPMAIL.NE.0) SEGSUP JPMAIL * END
© Cast3M 2003 - Tous droits réservés.
Mentions légales