C FPTUYA SOURCE CHAT 11/03/16 21:23:12 6902 SUBROUTINE FPTUYA(IPMODL,IPCHE1,IPTFP,IRET) C____________________________________________________________________ C C CALCULE LES FORCES DE PRESSIONS APPLIQUEES SUR DES TUYAUX C ( EFFET DE FOND ) APPELE PAR PRESSI C C C ENTREES : C --------- C C IPCHE1 POINTEUR SUR UN MCHAML DE CARACTERISTIQUES C IPMODL POINTEUR SUR UN MMODEL C C SORTIES C C C IPTFP CHPOINT DES FORCES NODALES EQUIVALENTES C IRET 1 OU 0 SI SUCCES OU NON C C M. PETIT NOVEMBRE 89 C PASSAGE AUX NOUVEAU CHAMELEM PAR JM CAMPENON LE 04 09 90 C C_____________________________________________________________________ C IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) C -INC CCOPTIO -INC CCREEL -INC SMCOORD -INC SMELEME -INC SMMODEL -INC SMCHAML -INC SMINTE * SEGMENT NOTYPE CHARACTER*16 TYPE(NBTYPE) ENDSEGMENT C SEGMENT MPTVAL INTEGER IPOS(NS) ,NSOF(NS) INTEGER IVAL(NCOSOU) CHARACTER*16 TYVAL(NCOSOU) ENDSEGMENT C CHARACTER*8 CMATE CHARACTER*(NCONCH) CONM PARAMETER ( NINF=3 ) INTEGER INFOS(NINF) LOGICAL lsupfo C DIMENSION XFORC(12),WORK(12),VECT(3) DIMENSION XE(3,2),P(3,3),XX(2),YY(2),ZZ(2) C IRET = 0 C NHRM=NIFOUR C C VERIFICATION DU LIEU SUPPORT DU MCHAML DE CARACTERISTIQUE C CALL QUESUP (IPMODL,IPCHE1,3,0,ISUP,IRETCA) IF (ISUP.GT.1) RETURN C C ACTIVATION DU MODELE C MMODEL=IPMODL SEGACT MMODEL NSOUS=KMODEL(/1) C C CREATION D UN MCHELM INTERMEDIAIRE C N1=NSOUS L1=5 N3=5 SEGINI MCHELM ICHAM=MCHELM TITCHE='FORCE' IFOCHE=IFOUR C C DEBUT DE LA BOUCLE SUR LES DIFFERENTES ZONES C DO 101 ISOUS=1,NSOUS C C ON RECUPERE L INFORMATION GENERALE C IMODEL=KMODEL(ISOUS) SEGACT IMODEL IPMAIL=IMAMOD CONM =CONMOD IMACHE(ISOUS)=IPMAIL CONCHE(ISOUS)=CONMOD C C TRAITEMENT DU MODELE C MELE=NEFMOD MELEME=IMAMOD C C INFORMATION SUR L'ELEMENT FINI C * CALL ELQUOI(MELE,0,3,IPINF,IMODEL) * IF (IERR.NE.0) THEN * SEGDES IMODEL,MMODEL * SEGSUP MCHELM * RETURN * ENDIF * INFO=IPINF MFR =INFELE(13) IF (MFR.EQ.13) GOTO 102 C SEGDES IMODEL,MMODEL * SEGSUP INFO SEGSUP MCHELM CALL ERREUR(16) RETURN C C ON A BIEN DES ELEMENTS TUYA C * 102 MINTE=INFELE(11) 102 MINTE=INFMOD(5) IPMINT=MINTE * SEGSUP INFO C C CREATION DU TABLEAU INFOS C CALL IDENT(IPMAIL,CONM,IPCHE1,0,INFOS,IRTD) IF (IRTD.EQ.0) THEN SEGDES IMODEL,MMODEL SEGSUP MCHELM RETURN ENDIF C INFCHE(ISOUS,1)=0 INFCHE(ISOUS,2)=0 INFCHE(ISOUS,3)=NHRM INFCHE(ISOUS,4)=MINTE INFCHE(ISOUS,5)=0 C C ACTIVATION DU MELEME C SEGACT MELEME NBNN =NUM(/1) NBELEM=NUM(/2) IPPORE=0 IF(MFR.EQ.33) IPPORE=NBNN C C RECHERCHE DES NOMS DE COMPOSANTES C if(lnomid(2).ne.0) then nomid=lnomid(2) segact nomid moforc=nomid nfor=lesobl(/2) nfac=0 lsupfo=.false. else lsupfo=.true. CALL IDFORC(MFR,IFOUR,MOFORC,NFOR,NFAC) endif C C TAILLE DES MELVAL A ALLOUER C N1PTEL=2 N1EL=NBELEM N2PTEL=0 N2EL=0 C C CREATION DU MCHAML DE LA SOUS ZONE C N2=NFOR SEGINI MCHAML ICHAML(ISOUS)=MCHAML NS=1 NCOSOU=NFOR SEGINI MPTVAL IVAFOR=MPTVAL NOMID=MOFORC SEGACT NOMID DO 1 ICOMP=1,NFOR NOMCHE(ICOMP)=LESOBL(ICOMP) TYPCHE(ICOMP)='REAL*8' SEGINI MELVAL IELVAL(ICOMP)=MELVAL IVAL(ICOMP)=MELVAL 1 CONTINUE SEGDES NOMID C C TRAITEMENT DES CHAMPS DE CARACTERISTIQUES C NBROBL=0 NBRFAC=0 MOCARA=0 NCARA=0 NCARF=0 NCARR=0 C C CARACTERISTIQUES POUR LES TUYAUX C NBROBL=3 NBRFAC=2 SEGINI NOMID MOCARA=NOMID LESOBL(1)='EPAI' LESOBL(2)='RAYO' LESOBL(3)='PRES' LESFAC(1)='RACO' LESFAC(2)='VECT' * NBTYPE=5 SEGINI NOTYPE MOTYPE=NOTYPE TYPE(1)='REAL*8' TYPE(2)='REAL*8' TYPE(3)='REAL*8' TYPE(4)='REAL*8' TYPE(5)='POINTEURPOINT ' C CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOCARA,MOTYPE,1,INFOS,3,IVACAR) SEGSUP NOTYPE IF (IERR.NE.0) GOTO 9990 MPTVAL=IVACAR NCARA=NBROBL NCARF=NBRFAC NCARR=NCARA+NCARF C IF (ISUP.EQ.1) THEN MINTE=IPMINT SEGACT,MINTE CALL VALCHE(IVACAR,NCARR,IPMINT,IPPORE) SEGDES,MINTE IF(IERR.NE.0)THEN ISUP=0 GOTO 9990 ENDIF ENDIF SEGDES NOMID C DO 103 IB=1,NBELEM C CALL DOXE(XCOOR,3,2,NUM,IB,XE) DO 105 J=1,2 XX(J)=XE(1,J) YY(J)=XE(2,J) ZZ(J)=XE(3,J) 105 CONTINUE C XLON2=(XX(2)-XX(1))**2+(YY(2)-YY(1))**2+(ZZ(2)-ZZ(1))**2 XLON=SQRT(XLON2) IF (XLON.NE.0.D0) GOTO 106 C INTERR(1)=ISOUS INTERR(2)=IB CALL ERREUR(128) GOTO 9990 C 106 CONTINUE C C ON CHERCHE LES CARACTERISTIQUE C CALL ZERO(XFORC,1,12) MPTVAL=IVACAR C MELVAL=IVAL(1) IBMN=MIN(IB,VELCHE(/2)) EPAI=VELCHE(1,IBMN) C MELVAL=IVAL(2) REXT=VELCHE(1,IBMN) C IF (IVAL(4).NE.0) THEN MELVAL=IVAL(4) RACO=VELCHE(1,IBMN) ELSE RACO=0. ENDIF C MELVAL=IVAL(3) PRES=VELCHE(1,IBMN) C IF (IVAL(NCARR).NE.0) THEN MELVAL=IVAL(NCARR) IBMN=MIN(IB,IELCHE(/2)) IP=IELCHE(1,IBMN) IREF=(IP-1)*(IDIM+1) DO 6129 IC=1,3 VECT(IC)=XCOOR(IREF+IC) 6129 CONTINUE ELSE DO 6229 IC=1,3 VECT(IC)=0. 6229 CONTINUE ENDIF C C RINT=REXT-EPAI FL=XPI*PRES*RINT**2 IF (RACO.NE.0.D0) THEN FL=FL/SQRT(1.D0-0.25D0*XLON2/RACO**2) ENDIF CALL ZERO(WORK,1,12) WORK(1)=-FL WORK(7)=FL C CALL POUPAS(XX,YY,ZZ,VECT,P,KERRE) IF (KERRE.EQ.0) GOTO 107 C INTERR(1)=ISOUS INTERR(2)=IB CALL ERREUR(138) GOTO 9990 C 107 CONTINUE CALL POUVEC(WORK,XFORC,P,2) IE=0 C C REMPLISSAGE DU SEGMENT CONTENANT LES FORCES C MPTVAL=IVAFOR DO 104 IGAU=1,2 DO 104 ICOMP=1,6 MELVAL=IVAL(ICOMP) IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB ,VELCHE(/2)) IE=IE+1 VELCHE(IGMN,IBMN)=XFORC(IE) 104 CONTINUE C 103 CONTINUE C 510 SEGDES MELEME SEGDES IMODEL C NOMID=MOCARA IF (MOCARA.NE.0) SEGSUP NOMID IF (ISUP.EQ.1) THEN CALL DTMVAL(IVACAR,3) ELSE CALL DTMVAL(IVACAR,1) ENDIF C NOMID=MOFORC if(lsupfo)SEGSUP NOMID CALL DTMVAL(IVAFOR,1) C SEGDES MCHAML C 101 CONTINUE SEGDES MMODEL SEGDES MCHELM IRET = 1 CALL CHAMPO(ICHAM,0,IPTFP,IRET) CALL DTCHAM(ICHAM) RETURN C 9990 CONTINUE IRET=0 C C ERREUR DANS UNE SOUS ZONE, DESACTIVATION ET RETOUR C NOMID=MOCARA IF (MOCARA.NE.0) SEGSUP NOMID IF (ISUP.EQ.1) THEN CALL DTMVAL(IVACAR,3) ELSE CALL DTMVAL(IVACAR,1) ENDIF C NOMID=MOFORC if(lsupfo)SEGSUP NOMID CALL DTMVAL(IVAFOR,1) C SEGDES MELEME SEGDES IMODEL SEGDES MMODEL SEGSUP MCHELM C RETURN END