Télécharger la plaquette Cast3M


fr en

Télécharger depimp.eso

Retour à la liste

Numérotation des lignes : 

depimp

  1. C DEPIMP    SOURCE    GOUNAND   24/09/05    21:15:01     12003          
  2.       SUBROUTINE DEPIMP
  3.  
  4. ************************************************************************
  5. *     CE SUBROUTINE SERT A IMPOSER DES VALEURS DE DEPLACEMENTS
  6. *     IMPOSES NON NULS.
  7. *
  8. *  SYNTAXE  TOTO = DEPIMPOSE   BRIG  FLOT
  9. *     OU    TOTO = DEPIMPOSE   BRIG  CHPOI ( COMPOSANTES PRIMALES)
  10. *     OU    TOTO = DEPIMPOSE   BRIG  'RELA' CHPSCAL
  11. *
  12. *  ENTREE : BRIG = OBJET RIGIDITE DE TYPE  BLOQUAGE
  13. *           FLOT = VALEUR DU DEPLACEMENT A IMPOSER
  14. *           CHPOI   = chpoint AVEC LES DDLS PRIMALS
  15. *           CHPSCAL = CHPOINT DE SCALAIRE QUI PRECISE LA
  16. *                     VALEUR A IMPOSER EN CHAQUE POINT.
  17. *
  18. *  SORTIE : TOTO = OBJET DE TYPE CHPOINT (FLX)
  19. *
  20. ************************************************************************
  21.  
  22. ************************************************************************
  23. *     DECLARATIONS ET INITIALISATIONS
  24. ************************************************************************
  25.  
  26.       IMPLICIT INTEGER(I-N)
  27.       IMPLICIT REAL*8(A-H,O-Z)
  28. *
  29.       CHARACTER*4 charm
  30.       LOGICAL ISCALA
  31.       PARAMETER(NCLE=1)
  32.       CHARACTER*4 MOCLE(NCLE)
  33.       DATA MOCLE  /'RELA'/
  34.  
  35. -INC SMRIGID
  36. -INC SMCHPOI
  37.  
  38. -INC PPARAM
  39. -INC CCOPTIO
  40. -INC SMELEME
  41. -INC SMCOORD
  42. -INC SMTABLE
  43.  
  44.       character*4 cnoha
  45.       integer*4 inoha
  46.       data cnoha/'NOHA'/
  47.       equivalence(inoha,cnoha)
  48.  
  49.       SEGMENT SCOLOR
  50.        CHARACTER*(LOCOMP) COLOR(NBELEM)
  51.       ENDSEGMENT
  52.       POINTEUR SCOL1.SCOLOR,SCOL2.SCOLOR,SCOL3.SCOLOR
  53.       SEGMENT ICPR(NNN)
  54.  
  55.  
  56. C     INITIALISATIONS
  57.       ISCALA = .FALSE.
  58.  
  59.  
  60. ************************************************************************
  61. *     LECTURES ET TESTS PRELIMINAIRES DES ENTREES
  62. ************************************************************************
  63.  
  64. C  ****  LECTURE TABLE LIAISONS STATIQUES
  65.       CALL LIRTAB('LIAISONS_STATIQUES',ipt,0,iretou)
  66.       IF (IRETOU.NE.0) THEN
  67.         CALL DEPIM2(IPT)
  68.         RETURN
  69.       ENDIF
  70. C
  71. C  ****  LECTURE D'UN OBJET DE TYPE RIGIDITE
  72. C
  73.       CALL LIROBJ('RIGIDITE',IPOIRI,1,IRETOU)
  74.       IF(IERR.NE.0) RETURN
  75. C
  76. C  ****  LECTURE D'UN FLOTTANT OU D'UN CHPOINT
  77. C
  78. C     LECTURE D'UNE VALEUR
  79.       CALL LIRREE(XXA,0,IREVAL)
  80.       VVAL=XXA
  81. c     SI ECHEC LECTURE D'UN CHPOINT DE SCALAIRES OU DE DDL PRIMAL
  82.       IF(IREVAL.EQ.0) THEN
  83.  
  84. *         mot-cle 'RELA' ? ==> ISCALA
  85.           CALL LIRMOT(MOCLE,NCLE,ICLE,0)
  86.           IF(IERR.NE.0) RETURN
  87.           IF(ICLE.EQ.1) ISCALA=.TRUE.
  88. *
  89.           CALL LIROBJ('CHPOINT ',ISCA,1,IRETOU)
  90.           IF(IERR.NE.0) RETURN
  91.           MCHPO1=ISCA
  92. c           SEGACT MCHPO1
  93.           CALL ACTOBJ('CHPOINT ',MCHPO1,1)
  94. C         Si le CHPOINT n'a aucune sous-zone, il est vide, alors erreur
  95.           NBSZCH=MCHPO1.IPCHP(/1)
  96.           IF(NBSZCH.LT.1) THEN
  97.              MOTERR(1:8)='CHPOINT '
  98.              INTERR(1)=ISCA
  99.              CALL ERREUR(356)
  100.              RETURN
  101.           ENDIF
  102.  
  103. c         RELA => cas SCALAIRE : 1 zone et 1 composante nommee 'SCAL'
  104.           IF(ISCALA) THEN
  105. c           verif : 1 seule zone
  106.             IF(NBSZCH.NE.1) THEN
  107.               MOTERR(1:8)='CHPOINT '
  108.               INTERR(1)=ISCA
  109. c             Le %m1:8 de pointeur %i1 n'est pas elementaire (n<>1)
  110.               CALL ERREUR(110)
  111.               RETURN
  112.             ENDIF
  113.             MSOUP1 = MCHPO1.IPCHP(1)
  114. c           segact MSOUP1
  115. c           verif : 1 seule composante
  116.             NBCOMP = MSOUP1.NOHARM(/1)
  117.             IF(NBCOMP.NE.1) THEN
  118. c             Il faut specifier un champ par point avec une seule composante
  119.               CALL ERREUR(180)
  120.               RETURN
  121.             ENDIF
  122.             IF(MSOUP1.NOCOMP(1).NE.'SCAL') THEN
  123.               MOTERR(1:4)='SCAL'
  124. c             La composante %m1:4 ne peut etre extraite du champ par point specifie
  125. c             car elle en est absente
  126.               CALL ERREUR(181)
  127.               RETURN
  128.             ENDIF
  129. c           ici ISCALA=TRUE et tout va bien !
  130.          ENDIF
  131.  
  132.       ENDIF
  133. c
  134. c  ... test si la RIGIDITE n'est pas vide, si OUI on cree un CHPOINT
  135. c      vide puis on s'en va ...
  136. c
  137.       MRIGID=IPOIRI
  138.       SEGACT,MRIGID
  139.       NNN=IRIGEL(/2)
  140.       IF (NNN.EQ.0) THEN
  141.          NSOUPO=0
  142.          NAT=1
  143.          SEGINI MCHPOI
  144.          MTYPOI='FLX'
  145.          JATTRI(1) = 2
  146.       MOCHDE=' CE CHAMP PAR POINTS A ETE CREE PAR LE SOUS-PROGRAMME'//
  147.      #  ' DEPIMP'
  148.          IFOPOI = IFOUR
  149.          GO TO 252
  150.       ENDIF
  151.  
  152.  
  153. ************************************************************************
  154. *    TRAVAIL
  155. ************************************************************************
  156.  
  157.       IPT2=0
  158.       NOHA=0
  159. C
  160. ************************************************************************
  161. C BOUCLE SUR LES SOUS RIGIDITES . ON VERIFIE QUE LAMBDA EXISTE ET ON
  162. C CONSTRUIT LE SEGMENT GEOMETRIE LX1 LX2 NNOE, DANS scol1.COLOR ON MET LE
  163. C NOM DE L'INCONNUE
  164. ************************************************************************
  165. C
  166.       DO 1 NN=1,NNN
  167.          DESCR=IRIGEL(3,NN)
  168.          MELEME=IRIGEL(1,NN)
  169.          NOHAR=IRIGEL(5,NN)
  170.          IF(NOHA.NE.0.AND.NOHA.NE.NOHAR) THEN
  171.             CALL ERREUR ( 25 )
  172.             RETURN
  173.          ENDIF
  174. c    ... on va chercher les multiplicateurs dans DESCR ...
  175.          SEGACT,DESCR
  176.          IA=LISINC(/2)
  177.          if (ia.ne.noelep(/1)) then
  178.           write(6,*) ' descr longueur ',descr,ia
  179.           call erreur(5)
  180.          endif
  181.          DO 2 I=1,IA
  182.             IF(LISINC(I).EQ.'LX  ') GO TO 3
  183.     2    CONTINUE
  184. c    ... on n'a pas trouve de multiplicateurs, donc bye ...
  185.          SEGDES,DESCR
  186.          CALL ERREUR(245)
  187.          RETURN
  188. c    ... on a trouve les multiplicateurs ...
  189.    3     CONTINUE
  190.          SEGACT,MELEME
  191.          NBNN=2
  192.          NBELEM=NUM(/2)
  193.          NBREF=0
  194.          NBSOUS=0
  195.          SEGINI,IPT1,SCOL1
  196. c    ... boucle sur les elements de blocage ...
  197.          DO J=1,NUM(/2)
  198.             JB=0
  199. c       ... JA sert a compter les multiplicateurs dans chaque
  200. c           element, un seul est permis
  201.             JA=0
  202. c       ... boucle sur les noeuds de ces elements ...
  203.             DO K=1,NOELEP(/1)
  204. c          ... si c'est un support de multiplicateur, on met son n°
  205. c              dans IPT1 (position 1 ) ...
  206.                IF(LISINC(K).EQ.'LX  ') THEN
  207.                   JA=JA+1
  208.                   if (ja.gt.1) then
  209.                    write(6,*) ' plus que 1 LX dans la matrice ',descr
  210.                    call erreur(5)
  211.                   endif
  212.                   IPT1.NUM(JA,J)=NUM(NOELEP(K),J)
  213. c          ... sinon ...
  214.                ELSE
  215. c             ... on teste si c'est le premier DDL <<physique>>, si OUI ...
  216.                   IF(JB.EQ.0) THEN
  217. c                ... on met son n° dans IPT1 (position 2) ...
  218.                      JB=2
  219.                      IPT1.NUM(JB,J)=NUM(NOELEP(K),J)
  220. C                ... et le nom du DDL dans SCOL1.COLOR ...
  221.                      SCOL1.COLOR(J)=LISINC(K)
  222. c             ... sinon (c.a d. ceci est une relation et non un blocage) ...
  223.                   ELSE
  224. c                ... on teste si le support n'est pas le même que
  225. c                    celui du premier DDL <<physique>> ...
  226.                      IF(IPT1.NUM(JB,J).NE.NUM(NOELEP(K),J)) THEN
  227. c                   ... si c'est le cas on sert une ERREUR en cas de lecture d'un CHPOINT ...
  228.                         IF(IREVAL.ne.1) then
  229.                            CALL ERREUR(794)
  230.                            RETURN
  231.                         endif
  232.                      ENDIF
  233. c                ... et de toute façon on efface le nom du DDL de SCOL1.COLOR ...
  234.                      SCOL1.COLOR(J)=' '
  235.                   ENDIF
  236.                ENDIF
  237.             ENDDO
  238.          ENDDO
  239.  
  240. C
  241. C  SI NN= 1 IPT2 = IPT1; SINON IPT3 = IPT2 + IPT1, PUIS IPT2 = IPT3
  242. C
  243.          SEGDES,DESCR
  244.          IF(IPT2.NE.0) GO TO 5
  245.          IPT2=IPT1
  246.          SCOL2=SCOL1
  247.          GO TO 1
  248.     5    CONTINUE
  249.          NA=IPT1.NUM(/2)
  250.          NB=IPT2.NUM(/2)
  251.          NBELEM=NA+NB
  252.          SEGINI,IPT3,SCOL3
  253.          DO 71 I=1,NA
  254.             SCOL3.COLOR(I)=SCOL1.COLOR(I)
  255.             DO 72 J=1,2
  256.                IPT3.NUM(J,I)=IPT1.NUM(J,I)
  257.    72       CONTINUE
  258.    71    CONTINUE
  259.          DO 8 I=1,NB
  260.             SCOL3.COLOR(I+NA)=SCOL2.COLOR(I)
  261.             DO 9 J=1,2
  262.                IPT3.NUM(J,I+NA)=IPT2.NUM(J,I)
  263.     9       CONTINUE
  264.     8    CONTINUE
  265.          SEGSUP IPT1,SCOL1
  266.          SEGSUP,IPT2,SCOL2
  267.          IPT2=IPT3
  268.          SCOL2=SCOL3
  269.     1 CONTINUE
  270.       SEGDES,MRIGID
  271. C
  272. C ON VIENT DE CREER IPT2 CONTENANT DES ELEMENTS COMPOSES DE LX1  NOE
  273. C DANS COLOR ON A LE NOM DE L'INCONNUE A METTRE EN FACE DE NNOE
  274. C
  275.       NSOUPO=1
  276.       NAT=1
  277.       SEGINI,MCHPOI
  278.       MTYPOI='FLX'
  279.       JATTRI(1) = 2
  280.       MOCHDE=' CE CHAMP PAR POINTS A ETE CREE PAR LE SOUS-PROGRAMME'//
  281.      #  ' DEPIMP'
  282.       IFOPOI=IFOUR
  283.  
  284.       NC=1
  285.       SEGINI,MSOUPO
  286.       IPCHP(1)=MSOUPO
  287.       NOCOMP(1)='FLX'
  288.       NOHARM(1)=NOHAR
  289.       write (charm,fmt='(A4)') nohar
  290.       if (nohar.eq.inoha) noharm(1)=nifour
  291. C
  292. ************************************************************************
  293. C  CREATION DE L'ELEMENT SUPPORT GEOMETRIQUE ET EN MEME TEMPS DES
  294. C  VALEURS VPOCHA
  295. ************************************************************************
  296. C
  297.       NBNN=1
  298.       NBELEM=IPT2.NUM(/2)
  299.       SEGINI MELEME
  300.       IGEOC=MELEME
  301.       ITYPEL=1
  302.  
  303.       N=IPT2.NUM(/2)
  304.       SEGINI,MPOVAL
  305.       IPOVAL=MPOVAL
  306.  
  307. c ... Si on a lu un reel, il n'y a pas grand chose a faire ...
  308.       IF(IREVAL.NE.0) GO TO 250
  309. C
  310. c
  311. C   + CAS DU CHPOINT SCALAIRE ------------------------------------------
  312. c     (on teste seulement ISCALA car on a deja verifie que cela va
  313. c      ensemble avec LLLREL)
  314.       IF(ISCALA) THEN
  315. c           write(*,*) '>>> DEPI d un chpoint SCALAIRE <<<'
  316.           MSOUP1=MCHPO1.IPCHP(1)
  317.           SEGACT MSOUP1
  318.           MPOVA1=MSOUP1.IPOVAL
  319.           SEGACT MPOVA1
  320.           NNN=nbpts
  321.           SEGINI ICPR
  322.           IPT3=MSOUP1.IGEOC
  323.           SEGACT IPT3
  324.           NNU=IPT3.NUM(/2)
  325. c         numerotation locale
  326.           DO 25 IUY=1,NNU
  327.              ICPR(IPT3.NUM(1,IUY))=IUY
  328.   25      CONTINUE
  329.           DO 26 IU=1,IPT2.NUM(/2)
  330.              NUM(1,IU)=IPT2.NUM(1,IU)
  331.              INOD2=IPT2.NUM(2,IU)
  332.              ID=ICPR(INOD2)
  333.              IF(ID.EQ.0) THEN
  334. c              ERREUR : "Un point de l'objet rigidite n'est pas
  335. c                        inclus dans le champ de scalaire"
  336.                CALL ERREUR(244)
  337.                RETURN
  338.              ELSEIF(ID.EQ.-1) THEN
  339. c              Le noeud apparait dans plusieurs relations --> ERREUR :
  340. c              "On ne peut avoir 2 relations sur un meme ddl  noeud %i1"
  341.                 INTERR(1)=INOD2
  342.                 CALL ERREUR(886)
  343.                 RETURN
  344.              ELSE
  345.                 XXA=MPOVA1.VPOCHA(ID,1)
  346.                 VPOCHA(IU,1)=XXA
  347.                 ICPR(INOD2)=-1
  348.              ENDIF
  349.    26     CONTINUE
  350.           SEGSUP ICPR
  351. C
  352. C    + CAS DU CHPOINT D'INCONNUES PRIMALES -----------------------------
  353.        ELSE
  354.           NBLOC=0
  355.           NNN=nbpts
  356.           SEGINI ICPR
  357.           JB=1
  358.           DO 36 J=1,IPT2.NUM(/2)
  359.              NUM(1,JB)=IPT2.NUM(1,J)
  360.              JB=JB+1
  361.  36       CONTINUE
  362.           DO 31 I=1,MCHPO1.IPCHP(/1)
  363.              DO 40 J=1,NNN
  364.                 ICPR(J)=0
  365.  40          CONTINUE
  366.              MSOUP1=MCHPO1.IPCHP(I)
  367.              SEGACT MSOUP1
  368.              MPOVA1=MSOUP1.IPOVAL
  369.              SEGACT MPOVA1
  370.              IPT1=MSOUP1.IGEOC
  371.              SEGACT IPT1
  372.              IA=0
  373.              DO 32 J=1,IPT1.NUM(/2)
  374.                 ID=IPT1.NUM(1,J)
  375.                 IF(ICPR(ID).EQ.0) THEN
  376.                    IA=IA+1
  377.                    ICPR(ID)=IA
  378.                 ELSE
  379. C  75 2
  380. C     Le maillage a un point en double
  381.                    CALL ERREUR(75)
  382.                    RETURN
  383.                 ENDIF
  384.  32          CONTINUE
  385.              DO 33 J=1,IPT2.NUM(/2)
  386.                 ID=IPT2.NUM(2,J)
  387.                 IF(ICPR(ID).EQ.0) GO TO 33
  388.                 DO 34 K=1,MSOUP1.NOCOMP(/2)
  389.                    IF(MSOUP1.NOCOMP(K).EQ.SCOL2.COLOR(J)) GO TO 35
  390.  34             CONTINUE
  391.                 GO TO 33
  392.  35             CONTINUE
  393.                 JD=ICPR(ID)
  394.                 XXA=MPOVA1.VPOCHA(JD,K)
  395.                 JA=J
  396.                 VPOCHA(JA,1)=XXA
  397.                 NBLOC=NBLOC+1
  398.  33          CONTINUE
  399.  31       CONTINUE
  400. *     Aucune valeur n'a ete imposee
  401.           IF (NBLOC.EQ.0) THEN
  402. * 1144 2
  403. * Aucune valeur du champ en entree n'a ete utilisee. Verifiez les donnees.
  404.              CALL ERREUR(1144)
  405.              RETURN
  406.           ENDIF
  407.           SEGSUP ICPR
  408.       ENDIF
  409. C   + FIN CAS DES CHPOINTS SCALAIRE OU PAS -----------------------------
  410. c     le chpoint d'entree est inutile -> segdes
  411.       CALL ACTOBJ('CHPOINT ',MCHPO1,0)
  412.       GO TO 251
  413.  
  414.  
  415. C     CAS DU FLOTTANT --------------------------------------------------
  416. C ... En cas de lecture d'un reel le remplissage du segment MPOVAL est assez simple ...
  417.   250 CONTINUE
  418.       DO 10 I=1,N
  419.          VPOCHA(I,1)=VVAL
  420.    10 CONTINUE
  421. c ... celui du segment MELEME n'est pas plus complique ...
  422.       DO 11 I=1,IPT2.NUM(/2)
  423.          NUM(1,I)=IPT2.NUM(1,I)
  424.    11 CONTINUE
  425.  
  426.  
  427. c     TOUS LES CAS -----------------------------------------------------
  428.   251 CONTINUE
  429.       SEGSUP IPT2,SCOL2
  430.   252 CONTINUE
  431. c     chpoint de sortie -> segact
  432.       CALL ACTOBJ('CHPOINT ',MCHPOI,1)
  433.       CALL ECROBJ('CHPOINT ',MCHPOI)
  434.  
  435.       END
  436.  
  437.  

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