C FSURCO SOURCE FANDEUR 12/07/18 21:15:42 7434 SUBROUTINE FSURCO(IPMODL,IPCHPS,IPVECT,IPCARA, IPTFP) *_____________________________________________________________________ * * CALCULE LES FORCES DE PRESSIONS APPLIQUEES SUR DES COQUES * * ENTREES : * --------- * * IPMODL OBJET AFFECTE SUR LEQUEL S APPLIQUE LA PRESSION * IPCHE1 CHPOINT CONTENANT LES VALEURS DES FORCES AUX NOEUDS * IPVECT VECTEUR INDIQUANT LA DIRECTION DANS LAQUELLE * S APPLIQUE LA FORCE SURFACIQUE * * SORTIES : * --------- * * IPTFP CHPOINT DES FORCES NODALES EQUIVALENTES * *_____________________________________________________________________ * 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 * SEGMENT NOTYPE CHARACTER*16 TYPE(NBTYPE) ENDSEGMENT * SEGMENT MPTVAL INTEGER IPOS(NS) ,NSOF(NS) INTEGER IVAL(NCOSOU) CHARACTER*16 TYVAL(NCOSOU) ENDSEGMENT * PARAMETER (NINF=3) INTEGER INFOS(NINF) DIMENSION V(3),ipt(3) CHARACTER*4 mfors(3) CHARACTER*(NCONCH) CONM C= LEFCOQ Liste des numeros d'elements finis COQUEs C= NEFCOQ Longueur de cette liste PARAMETER ( NEFCOQ = 8 ) DIMENSION LEFCOQ(NEFCOQ) C ============ C Elements COQUEs COQ2 COQ3 COQ6 COQ4 COQ8 DKT POI1 DST DATA LEFCOQ / 44, 27, 56, 49, 41, 28, 45, 93 / LOGICAL ltelq, lsupfo * * 0) QUELQUES INITIALISATIONS * IPTFP = 0 NHRM = NIFOUR C= Composantes du CHPOINT IPCHPS a retenir (si besoin) IF (IFOMOD.EQ.2) THEN nfors = 3 mfors(1) = 'FX ' mfors(2) = 'FY ' mfors(3) = 'FZ ' ELSE IF (IFOMOD.EQ.-1) THEN nfors = 2 mfors(1) = 'FX ' mfors(2) = 'FY ' mfors(3) = ' ' ELSE IF (IFOMOD.EQ.0) THEN nfors = 2 mfors(1) = 'FR ' mfors(2) = 'FZ ' mfors(3) = ' ' ELSE IF (IFOMOD.EQ.1) THEN nfors = 3 mfors(1) = 'FR ' mfors(2) = 'FZ ' mfors(3) = 'FT ' ELSE CALL ERREUR(21) RETURN ENDIF C= Cas des modes de calculs en DEFORMATIONS GENERALISEES IF (IFOUR.EQ.-3) THEN NDPGE = 3 ELSE NDPGE = 0 ENDIF * IPCHMS = 0 IPCHMZ = 0 * * 1) ON RECUPERE LES COORDONNEES DU VECTEUR CONSTANT (SI DONNE) * V(1) = 0.D0 V(2) = 0.D0 V(3) = 0.D0 IF (IPVECT.NE.0) THEN IREF=(IPVECT-1)*(IDIM+1) V(1)=XCOOR(IREF+1) V(2)=XCOOR(IREF+2) VN = V(1)**2 + V(2)**2 IF (IDIM.GE.3) THEN V(3)=XCOOR(IREF+3) VN=VN+V(3)**2 ENDIF c* VN=SQRT(VN) IF (VN.LE.0.) THEN CALL ERREUR(277) RETURN ENDIF ENDIF * * 2) VERIFICATIONS DU CHAMP DE CARACTERISTIQUES SI FOURNI * IF (IPCARA.NE.0) THEN CALL QUESUP(IPMODL,IPCARA,3,0,ISUPCA,iret) IF (ISUPCA.GT.1) RETURN ENDIF * * 3) ANALYSE DU CHPOINT DE FORCES SURFACIQUES SI DONNE * IFLAG SERT A INDIQUER SI L'ON DOIT OU NON DETRUIRE LE MODELE IPMODI * ( 1 = DESTRUCTION DU MMODEL IPMODI CREE ) * IF (IPCHPS.NE.0) THEN * IFLAG = 1 * * ON CREE L OBJET MAILLAGE CONTENANT TOUS LES POINTS DU CHPOINT * CORRESPONDANT AUX SEULES COMPOSANTES RECHERCHEES (mfors) * IPGEOM = 0 * MCHPOI=IPCHPS SEGACT,MCHPOI NSOUPO=IPCHP(/1) ltelq=.FALSE. DO I = 1, NSOUPO MSOUPO=IPCHP(I) SEGACT,MSOUPO NC = NOCOMP(/2) DO j = 1, NC CALL PLACE(mfors,nfors,imo,NOCOMP(j)) IF (imo.NE.0) THEN IF (IPGEOM.EQ.0) THEN IPGEOM = IGEOC ELSE IPP2 = IGEOC CALL FUSE (IPGEOM,IPP2,IPPT,ltelq) IF (IERR.NE.0) RETURN IPGEOM = IPPT ENDIF GOTO 10 ENDIF ENDDO 10 CONTINUE SEGDES,MSOUPO ENDDO SEGDES,MCHPOI IF (IPGEOM.EQ.0) THEN CALL ERREUR(21) RETURN ENDIF * * ON CREE UN MODELE S'ACCROCHANT AU CHPOINT * MMODEL = IPMODL SEGACT,MMODEL NSOUS = MMODEL.KMODEL(/1) * N1 = NSOUS SEGINI,MMODE1=MMODEL IPMODI = MMODE1 * * BOUCLE SUR LES SOUS ZONES GEOMETRIQUES ELEMENTAIRES * N1 = 0 lzero = 0 * DO 11 ISOUS = 1, NSOUS * IMODEL=KMODEL(ISOUS) SEGACT,IMODEL ITGEOM=IMAMOD SEGDES,IMODEL * CALL ECROBJ('MAILLAGE',IPGEOM) CALL ECRCHA('STRI') CALL ECRCHA('APPU') CALL ECROBJ('MAILLAGE',ITGEOM) CALL EXTREL(irr,0,ibnor) * * LE CHPOINT ET LA SOUS-ZONE N'ONT PAS D'ELEMENT EN COMMUN * IF (irr.GT.0) GOTO 11 * * DEFINITION DU SOUS-MODELE ASSOCIE A L'INTERSECTION CALL LIROBJ('MAILLAGE',IPOGEO,1,IRETOU) IF (IERR.NE.0) GOTO 9990 * N1 = N1 + 1 * * CREATION DE L'OBJET IMODEL DE CETTE SOUS ZONE * SEGINI,IMODE1=IMODEL IMODE1.IMAMOD=IPOGEO CALL INOMID(IMODE1,' ',iret,lzero,lzero,lzero,lzero) CALL PRQUOI(IMODE1) SEGDES,IMODE1 MMODE1.KMODEL(N1) = IMODE1 * 11 CONTINUE SEGDES,MMODEL * * LE MODELE ET LE CHPOINT SONT INCOMPATIBLES * IF (N1.EQ.0) THEN MOTERR(1:8)='MAILLAGE' MOTERR(9:16)='CHPOINT' CALL ERREUR(135) IFLAG = 0 SEGSUP,MMODE1 GOTO 9990 ENDIF * IF (N1.NE.NSOUS) THEN SEGADJ,MMODE1 ENDIF * * ON TRANSFORME LE CHPOINT DE VECTEUR EN MCHAML AUX NOEUDS * CALL CHAME1(0,IPMODI,IPCHPS,' ',IPCHMS,1) IF (IERR.NE.0) GOTO 9990 MCHEL1=IPCHMS SEGACT,MCHEL1 * ELSE IFLAG = 0 IPMODI = IPMODL ENDIF * * ACTIVATION DU MODELE * MMODEL = IPMODI SEGACT,MMODEL NSOUS = KMODEL(/1) * * INITIALISATION DU MCHAML ELEMENTAIRE DES FORCES NODALES * N1 = NSOUS L1 = 6 N3 = 6 SEGINI,MCHELM IPCHMZ = MCHELM TITCHE = 'FORCES' IFOCHE = IFOUR * DO 100 ISOUS = 1, NSOUS * * ON RECUPERE L INFORMATION GENERALE * IMODEL=KMODEL(ISOUS) SEGACT,IMODEL * MOCARA = 0 IVACAR = 0 MOFORC = 0 IVAFOR = 0 * * TRAITEMENT DU MODEL * IPMAIL=IMAMOD CONM =CONMOD MELE =NEFMOD imo = 0 CALL PLACE2(LEFCOQ,NEFCOQ,imo,MELE) * * ERREUR L ELEMENT N EST PAS ENCORE IMPLEMENTE IF (imo.EQ.0) THEN MOTERR(1:4) = NOMTP(MELE) MOTERR(5:12)='FSURCO ' CALL ERREUR(86) GOTO 9900 ENDIF IF (MELE.EQ.41.OR.MELE.EQ.56) THEN IF (IPCARA.EQ.0) THEN C* Revoir l'erreur MOTERR(1:4) = NOMTP(MELE) MOTERR(5:12)='FSURCO ' CALL ERREUR(86) GOTO 9900 ENDIF ENDIF * * INFORMATION SUR L ELEMENT FINI * MFR =INFELE(13) IPTINT=INFMOD(5) IPTNOE=INFMOD(8) MINTE =IPTINT IF (IPTINT.NE.0) SEGACT,MINTE IPPORE=0 IF (MFR.EQ.33) IPPORE=NBNN * * CREATION DU TABLEAU INFOS * CALL IDENT(IPMAIL,CONM,IPCARA,IPCHMS,INFOS,iret) IF (iret.EQ.0) GOTO 9900 * IPT(1) = 0 IPT(2) = 0 IPT(3) = 0 IF (IPCHMS.NE.0) THEN MCHAM1 = MCHEL1.ICHAML(ISOUS) SEGACT,MCHAM1 DO i = 1, MCHAM1.NOMCHE(/2) CALL PLACE(mfors,nfors,imo,MCHAM1.NOMCHE(i)) if (imo.ne.0) IPT(imo) = MCHAM1.IELVAL(i) ENDDO SEGDES,MCHAM1 ENDIF * IMACHE(ISOUS)=IPMAIL CONCHE(ISOUS)=CONM INFCHE(ISOUS,1)=0 INFCHE(ISOUS,2)=0 INFCHE(ISOUS,3)=NHRM INFCHE(ISOUS,4)=IPTINT INFCHE(ISOUS,5)=0 INFCHE(1,6)=0 * MELEME=IPMAIL SEGACT,MELEME NBNN =NUM(/1) NBELEM=NUM(/2) * * RECHERCHE DES NOMS DE COMPOSANTES * IF (lnomid(2).ne.0) then lsupfo = .false. MOFORC = lnomid(2) else lsupfo = .true. CALL IDFORC (MFR,IFOUR,MOFORC,NFOR,NFAC) endif nomid=MOFORC SEGACT,nomid nfor = lesobl(/2) nfac = 0 NCOMP = NFOR - NDPGE N2 = NCOMP SEGINI,MCHAML ICHAML(ISOUS) = MCHAML NS=1 NCOSOU=NCOMP SEGINI,MPTVAL IVAFOR=MPTVAL * N1EL = NBELEM 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 ENDIF N2PTEL=0 N2EL =0 * 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 *_______________________________________________________________________ * * ELEMENTS COQ3 , DKT OU DKTC * --------------------------- IF (MELE.EQ.27 .OR. MELE.EQ.28 .OR. MELE.EQ.45 .OR. & MELE.EQ.93) THEN * CALL FSCO3D(IPT,IPMAIL,IPVECT,V,IVAFOR) * * ELEMENT COQ2 * ------------ ELSE IF (MELE.EQ.44) THEN * * TRAITEMENT DU CHAMP DE CARACTERISTIQUES * IF (IFOUR.EQ.-2 .AND. IPCARA.NE.0) THEN * NBROBL=0 NBRFAC=1 SEGINI,NOMID MOCARA=NOMID LESFAC(1)='DIM3' * NBTYPE=1 SEGINI,NOTYPE MOTYPE=NOTYPE TYPE(1)='REAL*8' * CALL KOMCHA(IPCARA,IPMAIL,CONM,MOCARA,MOTYPE,0, & INFOS,3,IVACAR) SEGSUP,NOTYPE IF (IERR.NE.0) GOTO 9990 * IF (ISUPCA.EQ.1) THEN NCARA=NBROBL NCARF=NBRFAC NCARR=NCARA+NCARF CALL VALCHE(IVACAR,NCARR,IPTINT,IPPORE) ENDIF * ENDIF CALL FSCO2D (IPT,IPMAIL,IPVECT,V,IVAFOR,IVACAR) * * ELEMENTS COQ4 * ------------- * ELSE IF (MELE.EQ.49) THEN * CALL FSCOQ4(IPT,IPMAIL,IPTINT,IPVECT,V,IVAFOR) * * ELEMENTS COQ6 OU COQ8 * --------------------- * ELSE IF (MELE.EQ.41.OR.MELE.EQ.56) THEN *____________________________________________________________________ * * TRAITEMENT DES CHAMPS DE CARACTERISTIQUES POUR LES COQ8 ET COQ6 *____________________________________________________________________ * NBROBL=1 NBRFAC=0 SEGINI,NOMID MOCARA=NOMID LESOBL(1)='EPAI' * NBTYPE=1 SEGINI,NOTYPE MOTYPE=NOTYPE TYPE(1)='REAL*8' * * CALL KOMCHA(IPCARA,IPMAIL,CONM,MOCARA,MOTYPE,1,INFOS,3,IVACAR) SEGSUP,NOTYPE IF (IERR.NE.0) GOTO 9990 * IF (ISUPCA.EQ.1) THEN NCARA=NBROBL NCARF=NBRFAC NCARR=NCARA+NCARF CALL VALCHE(IVACAR,NCARR,IPTINT,IPPORE) ENDIF * CALL FSCOQ8(IPT,IPMAIL,IPTINT,IPVECT,V,IVACAR,IPTNOE,IVAFOR) * ENDIF * DO ICOMP = 1, NCOMP MELVAL=IELVAL(ICOMP) SEGDES,MELVAL ENDDO * IF (IPTINT.NE.0) SEGDES,MINTE SEGDES,MELEME SEGDES,IMODEL * IF (MOCARA.NE.0) THEN NOMID = MOCARA SEGSUP,NOMID IF (ISUPCA.EQ.1) THEN CALL DTMVAL(IVACAR,3) ELSE CALL DTMVAL(IVACAR,1) ENDIF ENDIF * IF (MOFORC.NE.0) THEN nomid=MOFORC SEGDES,nomid IF (lsupfo) SEGSUP,nomid CALL DTMVAL(IVAFOR,1) ENDIF * 100 CONTINUE * * ON TRANSFORME LE MCHAML EN CHPOINT * CALL CHAMPO(IPCHMZ,0,IPTFP,iret) IF (iret.EQ.0) GOTO 9990 * * ERREUR DANS UNE SOUS ZONE, DESACTIVATION ET RETOUR * 9900 CONTINUE 9990 CONTINUE SEGDES,MMODEL * IF (IFLAG.EQ.1) CALL DTMODL(IPMODI) IF (IPCHMZ.NE.0) CALL DTCHAM(IPCHMZ) IF (IPCHMS.NE.0) CALL DTCHAM(IPCHMS) * RETURN END