Télécharger la plaquette Cast3M


fr en

Télécharger projba.eso

Retour à la liste

Numérotation des lignes : 

projba

  1. C PROJBA    SOURCE    CB215821  20/11/25    13:37:15     10792          
  2.       SUBROUTINE PROJBA(IP1,IP2,IP4,IRET)
  3.       IMPLICIT INTEGER(I-N)
  4.       IMPLICIT REAL*8(A-H,O-Z)
  5. C=======================================================================
  6. C SUBROUTINE APPELE PAR L OPERATEUR PJBA : PROJECTION DU CHPOINT IP1 SUR
  7. C LES ELEMENTS DE LA BASE MODALE IP2, SOUS BASE IP4.
  8. C LE RESULTAT EST MIS DANS IRET (CHPOINT).
  9. C   POUR DEBOGUER IMPEC=10
  10. C
  11. C  PROGRAMME PAR FARVACQUE
  12. C  APPELE PAR PJBA
  13. C  APPELLE : ETALPR,ETALCH,ERREUR(108,302,303)
  14. C=======================================================================
  15.  
  16. -INC PPARAM
  17. -INC CCOPTIO
  18. -INC CCREEL
  19. -INC SMCHPOI
  20. -INC SMELEME
  21. -INC SMATTAC
  22. -INC SMBASEM
  23. -INC SMSOLUT
  24. -INC CCHAMP
  25.       SEGMENT ITRAV(2)
  26.       SEGMENT ITTT(0)
  27.       SEGMENT ICPR(nbpts)
  28.       SEGMENT IINC
  29.        CHARACTER*(LOCOMP) CIINC(0)
  30.       ENDSEGMENT
  31.       SEGMENT IIDU
  32.        CHARACTER*(LOCOMP) CIIDU(NNI1)
  33.       ENDSEGMENT
  34.       SEGMENT/MVA/(VA(NNI1,IPR1)*D),MVA1.MVA
  35.       SEGMENT IPB(IPR1)
  36.       SEGMENT MCONTR(NNI1,IPR1)
  37.       SEGMENT/IWRK/(ITRAVV(LDEPL1,2),TRAV(LDEPL)*D)
  38.       CHARACTER*(LOCOMP) IDDL
  39.       DATA IMPEC/10/
  40.       DATA KZERO/0/
  41. C
  42.       IRET=0
  43. C
  44. C   DEPLACEMENT IMPOSE => IDEPI=1
  45. C   FORCE IMPOSEE      => IDEPI=0
  46. C
  47.       IDEPI=0
  48. C     IDEPI=-1
  49.       KDEPI=0
  50.       MCHPOI=IP1
  51.       SEGACT MCHPOI
  52.       IF(MTYPOI.EQ.'FLX     ') IDEPI=1
  53. C     IF(MTYPOI(1).EQ.MOFORC(1).AND.MTYPOI(2).EQ.MOFORC(2)) IDEPI=0
  54.       SEGDES MCHPOI
  55. C     IF(IDEPI.LT.0) THEN
  56. C       MOTERR(1:8)='CHPOINT'
  57. C       CALL ERREUR(302)
  58. C       RETURN
  59. C     ENDIF
  60. C
  61.       NBNN=1
  62.       NBREF=0
  63.       NBSOUS=0
  64.       MBASEM=IP2
  65.       SEGACT MBASEM
  66.       SEGINI ITRAV
  67.       SEGINI ITTT
  68.       MSOBAS=LISBAS(IP4)
  69.       SEGDES MBASEM
  70.       SEGACT MSOBAS
  71.       ITRAV(1)=IBSTRM(2)
  72.       ITRAV(2)=IBSTRM(3)
  73.       SEGDES MSOBAS
  74. C
  75.       DO 1 IT=1,2
  76.       MSOLUT=ITRAV(IT)
  77.       IF(MSOLUT.EQ.0) GO TO 1
  78.       SEGACT MSOLUT
  79.       MSOLEN=MSOLIS(5)
  80.       IF(IT.EQ.2) MSOLE1=MSOLIS(10)
  81.       MELEME=MSOLIS(3)
  82.       SEGDES MSOLUT
  83.       SEGACT MSOLEN
  84.       LDEPL=ISOLEN(/1)
  85.       LDEPL1=LDEPL+1
  86.       IF(IT.EQ.2) SEGINI IWRK
  87.       IF(IIMPI.EQ.IMPEC)WRITE(6,8000) IT,MSOLEN,MSOLE1,LDEPL
  88.  8000 FORMAT('  *****IT=',I4,'  MSOLEN=',I5,' MSOLE1=',I5,' LDEPL=',I5)
  89. C
  90. C  **** ETALPR DU CHPOINT DE LA SOLUTION
  91. C
  92.       IPM=ISOLEN(1)
  93.       CALL ETALPR(IPM,KIINC,KICPR,KCONTR)
  94.       IF(IERR.NE.0) GO TO 5000
  95.       MCONTR=KCONTR
  96.       SEGACT MCONTR
  97.       NNI1=MCONTR(/1)
  98.       IPR1=MCONTR(/2)
  99.       SEGDES MCONTR
  100.       SEGINI MVA
  101.       KMVA=MVA
  102.       SEGDES MVA
  103.       SEGINI MVA
  104.       KMVB=MVA
  105.       SEGDES MVA
  106.       SEGINI IPB
  107.       KIPB=IPB
  108.       SEGDES IPB
  109.       IINC=KIINC
  110.       SEGACT IINC
  111.       SEGINI IIDU
  112.       DO 6 I=1,NNI1
  113.       IDDL=CIINC(I)
  114.       DO 7 J=1,LNOMDD
  115.       IF(IDDL.NE.NOMDD(J))GO TO 7
  116.       CIIDU(I)=NOMDU(J)
  117.       GO TO 6
  118.  7    CONTINUE
  119.       MOTERR=IDDL
  120.       CALL ERREUR(108)
  121. C     ON NE TROUVE PAS IDDL DANS CCHAMP
  122.       GO TO 5000
  123.  6    CONTINUE
  124.       SEGDES IINC,IIDU
  125.       KINCDU=IIDU
  126.       IF(IIMPI.EQ.IMPEC)WRITE(6,8002)(CIINC(I),CIIDU(I),I=1,NNI1)
  127.  8002 FORMAT(20(1X,A4))
  128. C
  129. C  **** ON REGARDE SI LES POINTS DE F CORRESPONDENT
  130. C  **** ON MET F DANS KMVB
  131. C
  132.       CALL ETALCH(IP1,KINCDU,KICPR,KCONTR,KMVB,KIPB,NPR2,1)
  133.       IF(IERR.NE.0) GO TO 5000
  134. C
  135. C   **** SI IT=1 ON INITIALISE MSOUPO,MPOVAL,MELEME
  136. C
  137.       IF(IT.NE.1) GO TO 100
  138.       NC=1
  139.       SEGINI MSOUPO
  140.       NOCOMP(1)='FALF'
  141.       N=LDEPL
  142.       SEGINI MPOVAL
  143.       IPOVAL=MPOVAL
  144.       IGEOC=MELEME
  145.       SEGDES MSOUPO
  146.       IF(IDEPI.EQ.1) MSOLE2=MSOLIS(4)
  147.  100  CONTINUE
  148.       IF(IT.EQ.2) SEGACT MSOLE1
  149.       ICON1=0
  150.       ICON2=0
  151.       SEGACT MSOLEN,MELEME
  152. C
  153. C  ****BOUCLE SUR LES CHPOINTS DE DEPL
  154. C
  155.       DO 11 IM=1,LDEPL
  156.       XRET=0.D0
  157.       IPP1=ISOLEN(IM)
  158.       IPOIN=NUM(1,IM)
  159.       IF(IIMPI.EQ.IMPEC)WRITE(6,8003) IPP1,IPOIN
  160.  8003 FORMAT('   IPP1=',I6,'  IPOIN=',I6)
  161.       IF(IT.EQ.1.OR.IDEPI.NE.1) THEN
  162.         CALL ETALCH(IPP1,KIINC,KICPR,KCONTR,KMVA,KZERO,IBID,1)
  163.         IF(IERR.NE.0) GO TO 5000
  164. C
  165.         MVA=KMVA
  166.         IPB=KIPB
  167.         MVA1=KMVB
  168.         SEGACT MVA,MVA1,IPB
  169.         DO 80 J1=1,NPR2
  170.         JJ1=IPB(J1)
  171.         DO 80 I1=1,NNI1
  172.         XRET=XRET+VA(I1,JJ1)*MVA1.VA(I1,JJ1)
  173.  80     CONTINUE
  174.         SEGDES MVA,MVA1,IPB
  175.       ENDIF
  176. C
  177.       IF(IT.EQ.1) THEN
  178.         IF(IDEPI.EQ.1) THEN
  179.           MMODE=MSOLE2.ISOLEN(IM)
  180.           SEGACT MMODE
  181.           OM=FMMODD(1)
  182.           SEGDES MMODE
  183.           OM=2.D0*XPI*OM
  184.           OM=OM*OM
  185.           XRET=-XRET/OM
  186.         ENDIF
  187.         VPOCHA(IM,1)=XRET
  188.       ELSE
  189.         MJONCT=MSOLE1.ISOLEN(IM)
  190.         IF(IIMPI.EQ.IMPEC)WRITE(6,8004) MJONCT
  191.  8004   FORMAT('   MJONCT=',I6)
  192.         SEGACT MJONCT
  193.         IF(MJODDL.EQ.'LX') THEN
  194.           ITRAVV(IM,1)=IPOIN
  195.           ICON1=ICON1+1
  196.         ELSE
  197.           ITRAVV(IM,2)=IPOIN
  198.           ICON2=ICON2+1
  199.           IF(IP1.EQ.IPCHJO(1)) THEN
  200.             XRET=1.D0
  201.             KDEPI=1
  202.           ENDIF
  203.         ENDIF
  204.         SEGDES MJONCT
  205.         TRAV(IM)=XRET
  206.       ENDIF
  207.  11   CONTINUE
  208.       SEGDES MSOLEN,MELEME
  209.       SEGSUP MVA,MVA1,IPB
  210.       ICPR=KICPR
  211.       SEGSUP ICPR,IINC,IIDU
  212. C
  213.       GO TO(31,32),IT
  214. C
  215.  31   SEGDES MPOVAL,MELEME
  216.       ITTT(**)=MSOUPO
  217.       GO TO 30
  218.  32   CONTINUE
  219.       ITRAVV(LDEPL1,1)=ICON1
  220.       ITRAVV(LDEPL1,2)=ICON2
  221.       DO 40 I=1,2
  222.       NBELEM=ITRAVV(LDEPL1,I)
  223.       IF(NBELEM.EQ.0) GO TO 40
  224.       SEGINI MELEME
  225.       NC=1
  226.       SEGINI MSOUPO
  227.       IF(I.EQ.1) NOCOMP(1)='FBET'
  228.       IF(I.EQ.2) NOCOMP(1)='BETA'
  229.       N=NBELEM
  230.       SEGINI MPOVAL
  231.       IPOVAL=MPOVAL
  232.       IGEOC=MELEME
  233.       SEGDES MSOUPO
  234.       ITTT(**)=MSOUPO
  235.       IK=0
  236.       DO 41 J=1,LDEPL
  237.       IF(ITRAVV(J,I).EQ.0) GO TO 41
  238.       IK=IK+1
  239.       NUM(1,IK)=ITRAVV(J,I)
  240.       VPOCHA(IK,1)=TRAV(J)
  241.  41   CONTINUE
  242.       SEGDES MPOVAL,MELEME
  243.  40   CONTINUE
  244.       SEGDES MSOLE1
  245.       SEGSUP IWRK
  246. C
  247.  30   CONTINUE
  248.  1    CONTINUE
  249. C
  250. C  **** CREATION DU CHPOINT
  251. C
  252.       NSOUPO=ITTT(/1)
  253.       NAT=1
  254.       SEGINI MCHPOI
  255.       DO 60 I=1,NSOUPO
  256.       IPCHP(I)=ITTT(I)
  257.  60   CONTINUE
  258.       MOCHDE=' J''AI ETE FABRIQUE PAR L''OPERATEUR PROJBA'
  259. *     Champ de forces nodales: nature discrete
  260.       JATTRI(1)=2
  261.       SEGDES MCHPOI
  262.       IRET=MCHPOI
  263.       IF(IDEPI.NE.KDEPI) THEN
  264. C *** LA BASE NE CONTIENT PAS LA SOLUTION STATIQUE NECESSAIRE AU
  265. C *** CALCUL DE LA REPONSE AU DEPLACEMENT IMPOSE
  266.         CALL ERREUR(303)
  267.         CALL ECRCHA('GEOM')
  268.         CALL DTCHPO(MCHPOI)
  269.         IRET=0
  270.       ENDIF
  271.  5000 CONTINUE
  272.       SEGSUP ITTT,ITRAV
  273.       RETURN
  274.       END
  275.  
  276.  
  277.  
  278.  
  279.  
  280.  
  281.  
  282.  
  283.  
  284.  

© Cast3M 2003 - Tous droits réservés.
Mentions légales