Télécharger la plaquette Cast3M


fr en

Télécharger supcha.eso

Retour à la liste

Numérotation des lignes : 

supcha

  1. C SUPCHA    SOURCE    CB215821  22/07/20    15:39:46     11411          
  2.       SUBROUTINE SUPCHA
  3. c
  4. c   sous routine pour calculer le chargement
  5. c   sur les ddl maitres d'un super element
  6. c   option CHAR de SUPE
  7. c
  8. c
  9.       IMPLICIT INTEGER(I-N)
  10.       IMPLICIT REAL*8(A-H,O-Z)
  11. c
  12.  
  13. -INC PPARAM
  14. -INC CCOPTIO
  15. -INC SMELEME
  16. -INC SMRIGID
  17. -INC SMSUPER
  18. -INC SMMATRI
  19. -INC SMVECTD
  20. -INC SMCHPOI
  21. -INC TMTRAV
  22. -INC CCREEL
  23. c
  24.       CHARACTER*4 INC
  25.       SEGMENT NOHAR(0)
  26.       SEGMENT SNOMIN
  27.       CHARACTER*4 NOMIN(0)
  28.       ENDSEGMENT
  29.       SEGMENT SNOMDU
  30.       CHARACTER*4 NOMDU(0)
  31.       ENDSEGMENT
  32. c
  33. c
  34. c
  35.       CALL LIROBJ ('SUPERELE',MSUPER,1,IRETOU)
  36.       IF(IERR.NE.0) RETURN
  37.       CALL LIROBJ ('CHPOINT ',MCHPOI,1,IRETOU)
  38.       IF(IERR.NE.0) RETURN
  39.       SEGACT MSUPER
  40. c
  41. c
  42. c *** mcrout contient la decomposition modifiee de la rigidite
  43. c
  44.       MMATRI=MCROUT
  45. c
  46. c *** lecture de la geometrie et du descripteur lies a
  47. c *** la matrice de rigidite condensee du superelement
  48. c
  49.       MRIGID=MSURAI
  50.       SEGACT MRIGID
  51.       nbelem=0
  52.       nbnn=1
  53.       nbsous=0
  54.       nbref=0
  55.       segini ipt5
  56.       ipt5.itypel=1
  57.       in=0
  58.       do ir=2,irigel(/2)
  59.        meleme=irigel(1,ir)
  60.        segact meleme
  61.        nbelem=nbelem+num(/2)
  62.        segadj ipt5
  63.        do ip=1,num(/2)
  64.         in=in+1
  65.         ipt5.num(1,in)=num(1,ip)
  66.        enddo
  67.       enddo
  68. *     call ecmail(ipt5,0)
  69.       segact ipt5
  70.       ichr=0
  71.       if (nbelem.ne.0) call reduir(mchpoi,ipt5,ichr)
  72.       lagdua=msuper.islag
  73. *     write (6,*) ' supcha msurai ',msurai,lagdua
  74.       xMATRI=IRIGEL(4,1)
  75.       IPT1=IRIGEL(1,1)
  76.       segact ipt1
  77. *     call ecmail(ipt1)
  78.       DESCR=IRIGEL(3,1)
  79.       SEGACT DESCR
  80.       SEGINI SNOMIN,SNOMDU,NOHAR
  81.       NOMIN(**)=LISINC(1)
  82.       NOMDU(**)=LISDUA(1)
  83.       NOHAR(**)=IRIGEL(5,1)
  84.       DO 10 I=1,LISINC(/2)
  85.           N=NOMIN(/2)
  86.           DO 11  J=1,N
  87.               IF(LISINC(I).EQ.NOMIN(J)) GO TO 10
  88.    11     CONTINUE
  89.           NOMIN(**)=LISINC(I)
  90.           NOMDU(**)=LISDUA(I)
  91.           NOHAR(**)=IRIGEL(5,1)
  92.    10 CONTINUE
  93. c
  94. c *** dimension de la matrice condensee
  95. c
  96.       SEGACT xMATRI
  97. *      XMATRI=IMATTT(1)
  98. *      SEGACT XMATRI
  99.       NLIGRA=RE(/1)
  100. *      SEGDES XMATRI
  101.       SEGDES xMATRI
  102. c
  103. c *** transformation du chpoint en vecteur
  104. c
  105.       mchpo1=mchpoi
  106.       if (lagdua.ne.0) then
  107.        call copie2(mchpoi,mchpo1)
  108.        SEGACT MCHPO1
  109.        DO 432 I=1,mchpo1.IPCHP(/1)
  110.           MSOUPO=mchpo1.IPCHP(I)
  111.           SEGACT MSOUPO*MOD
  112.           IPT4=IGEOC
  113.           SEGINI,ipt5=ipt4
  114.           SEGDES ipt4
  115.           IGEOC=ipt5
  116.  432   CONTINUE
  117.        call dbbch(mchpo1,lagdua)
  118. *      call ecmail(lagdua,0)
  119. *      call ecchpo(mchpo1,0)
  120.       endif
  121.       CALL CHV2(MMATRI,MCHPO1,MVECTD,1)
  122. c
  123. c *** calcul du chargement condense
  124. c
  125.  
  126.       SEGACT MVECTD*MOD
  127.       SEGACT MMATRI
  128.       MILIGN=IILIGN
  129.       SEGACT MILIGN
  130.       NBNNMA=IPNO(/1)-NLIGRA
  131.       NNOEU=ILIGN(/1)
  132.       ILA=1
  133.  
  134.  
  135. * attention à la normalisation
  136.       MDNOR=IDNORM
  137.       SEGACT MDNOR
  138. *  boucle sur les ddl s
  139. *     write (6,*) ' vectbb -0 ',(vectbb(i),i=1,ipno(/1))
  140. *     write (6,*) ' dnor      ',(dnor  (i),i=1,ipno(/1))
  141.       vecmax=0.d0
  142.       DO 45 I = 1,IPNO(/1)
  143.           VECTBB(I)=VECTBB(I)*DNOR(I)
  144.           vecmax=max(vecmax,abs(vectbb(i)))
  145.   45  CONTINUE
  146.       vecref=vecmax*XZPREC*XZPREC
  147. *     write (6,*) ' vectbb -1 ',(vectbb(i),i=1,ipno(/1))
  148.  
  149. * fin normalisation
  150.  
  151. c
  152.       DO 1 I=1,NNOEU
  153.           LIGN=ILIGN(I)
  154.           SEGACT LIGN
  155.           NA=IMMM(/1)
  156.           DO 2 J=1,NA
  157.               IDEB=IPPVV(J)
  158.               IFIN=IPPVV(J+1)-1
  159.               AUX=0.D0
  160.               DO 21 INDIC=IDEB,IFIN
  161.                   IDEB2=IVPO(2*INDIC)
  162.                   IFIN2=IVPO(2*(INDIC+1))-1
  163.                   DO 23 K=IDEB2,IFIN2
  164.                    icol=k-ivpo(2*indic)+ivpo(2*indic-1)+
  165.      >                 ila-j -ivpo(2*(ifin)-1)+1
  166.                       IF(ICOL.ge.ILA) GOTO 24
  167.                       IF(ICOL.GT.NBNNMA) GOTO 24
  168.                       AUX=AUX+val(k)*vectbb(icol)
  169.  23               CONTINUE
  170.  24               CONTINUE
  171.  21           CONTINUE
  172.  22           CONTINUE
  173.               VECTBB(ILA)=VECTBB(ILA)-AUX
  174.               if (abs(vectbb(ila)).lt.vecref) vectbb(ila)=0.d0
  175.               ILA=ILA+1
  176.  2        CONTINUE
  177.           SEGDES LIGN
  178.  1    CONTINUE
  179.       SEGDES MILIGN
  180. c
  181. c *** creation du chpoint resultat
  182. c
  183.       SEGACT IPT1
  184.       NNNOE=IPT1.NUM(/1)
  185.       NNIN=NOMDU(/2)
  186.       SEGINI MTRAV
  187.       DO 4 I=1,NNNOE
  188.           IGEO (I)=IPT1.NUM(I,1)
  189.    4  CONTINUE
  190.       DO 5 I=1,NNIN
  191.           INCO(I)=NOMDU(I)
  192.           NHAR(I)=NOHAR(I)
  193.    5  CONTINUE
  194.       DO 6 I=1,NLIGRA
  195.           INOEU=NOELED(I)
  196.           INC=LISDUA(I)
  197.           DO 7 J=1,NNIN
  198.               IF(INC.EQ.NOMDU(J)) GO TO 8
  199.    7      CONTINUE
  200.    8      CONTINUE
  201.           IBIN(J,INOEU)=1
  202. * on oublie pas de denormaliser si les ddl maitres
  203. * ont ete normalisés
  204.           BB(J,INOEU)=VECTBB(NBNNMA+I)/DNOR(NBNNMA+I)
  205.    6  CONTINUE
  206.       CALL CRECHP(MTRAV,ISOLU)
  207.       if (ichr.ne.0) then
  208.         call adchpo(isolu,ichr,iret,1.d0,1.d0)
  209.         isolu=iret
  210.       endif
  211.       if(ierr.ne.0) return
  212. c
  213. c     champ de nature discrete
  214. c
  215.       MCHPOI = ISOLU
  216.       SEGACT, MCHPOI*MOD
  217.       JATTRI(1)=2
  218. *     call ecmail(lagdua)
  219. *     write (6,*) ' avant dbbcf dans supcha '
  220. *     call ecchpo(mchpoi)
  221.       if (lagdua.ne.0) call dbbcf(mchpoi,lagdua)
  222. *     write (6,*) ' apres dbbcf dans supcha '
  223. *     call ecchpo(mchpoi)
  224.  
  225.       SEGDES MCHPOI
  226. c
  227.       ISOLU = MCHPOI
  228.       CALL ECROBJ('CHPOINT ',ISOLU)
  229.       SEGDES MDNOR
  230.       SEGDES DESCR
  231.       SEGDES MMATRI
  232.       SEGDES MSUPER
  233.       SEGDES MRIGID
  234.       SEGDES IPT1
  235.       SEGSUP SNOMIN,SNOMDU,NOHAR,MVECTD,MTRAV
  236.       RETURN
  237.       END
  238. c
  239.  
  240.  
  241.  
  242.  
  243.  
  244.  
  245.  
  246.  
  247.  
  248.  
  249.  
  250.  

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