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

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