Télécharger la plaquette Cast3M


fr en

Télécharger remplx.eso

Retour à la liste

Numérotation des lignes : 

remplx

  1. C REMPLX    SOURCE    CB215821  20/11/25    13:38:59     10792          
  2.  
  3.       SUBROUTINE remplx(irig1,ipchp1,ipchp2 )
  4. c====================================================================
  5. c       remplissage des LX apres reso avec condensation
  6. c     entrees:
  7. c           mrigid  rigidité   de dependance  ( irigel(8,irig) # 0)
  8. C                (elle contient  les multiplicateurs)
  9. c           ipchp1  chpoint de force cree par
  10. C              (rigtot * soltot)  - ftot
  11. c     sorties:
  12. C           ipchp2  chpoint des multiplicateurs a reintroduire
  13. C           dans la solution globale
  14. C
  15. c====================================================================
  16. *  on suppose pour le moment qu'il n'y a qu'une seule harmonique de fourier
  17.  
  18.       IMPLICIT INTEGER(I-N)
  19.       IMPLICIT REAL*8(A-H,O-Z)
  20. -INC SMCHPOI
  21. -INC SMRIGID
  22. -INC SMELEME
  23. -INC SMCOORD
  24.  
  25. -INC PPARAM
  26. -INC CCOPTIO
  27. -INC CCGEOME
  28. -INC CCHAMP
  29.  
  30.       character*(LOCOMP) NOMM,nom2
  31. C
  32.       segment iccoun(ncomp)
  33. C
  34.       segment iicpr
  35.         integer icpr(nbpts),ivers(nbpts),iinb
  36.         real*8  cvers(nbpts)
  37.       endsegment
  38.  
  39.       segment siver2
  40.         integer invnum(nbpts)
  41.         integer iver2(nptc)
  42.         real*8  cver2(nptc)
  43.       endsegment
  44.  
  45.       SEGMENT SNOMIN
  46.         CHARACTER*(LOCOMP) NOMIN(0)
  47.       ENDSEGMENT
  48.  
  49.       SEGMENT SNOMDU
  50.         CHARACTER*(LOCOMP) NODUA(0)
  51.       ENDSEGMENT
  52.  
  53.       INTEGER IFO
  54.  
  55.  
  56.  
  57.       IFO = 0
  58.       mrigid = irig1
  59.       SEGACT mrigid
  60.       segini snomin,snomdu
  61. C        identification des  inconnues liees
  62.       DO 1501 I=1,IRIGEL(/2)
  63.          MELEME=IRIGEL(1,I)
  64. C          SEGACT MELEME
  65.          DESCR=IRIGEL(3,I)
  66.          ifo=irigel(5,i)
  67.          SEGACT DESCR
  68.          DO 1502 J=1,LISINC(/2)
  69.             IF(LISINC(J).EQ.'LX  '.AND.J.LE.1) GO TO 1502
  70.             IF(NOMIN(/2).EQ.0) THEN
  71.                NOMIN(**)=LISINC(J)
  72.                NODUA(**)=LISDUA(J)
  73.             ELSE
  74.                DO 1506 K=1,NOMIN(/2)
  75.                   IF(LISINC(J).EQ.NOMIN(K)) GO TO 1505
  76.  1506          CONTINUE
  77.                NOMIN(**)=LISINC(J)
  78.                NODUA(**)=LISDUA(J)
  79.  1505          CONTINUE
  80.             ENDIF
  81.  1502    CONTINUE
  82.          SEGDES DESCR
  83.  1501 CONTINUE
  84. *C       construction du tableau des duales
  85. *        segini snomdu
  86. *          do 325 il=1,nomin(/2)
  87. *          NOMM =nomin(IL)
  88. *          do 326 in = 1,lnomdd
  89. *          if (NOMM.EQ.NOMDD(in)) then
  90. **          NODUA(il) =NOMDU(in)
  91. *          goto 327
  92. *          endif
  93. *326       continue
  94. *327       continue
  95. *325       continue
  96.  
  97. C     WRITE(IOIMP,*) 'primales bloquees' ,(nomin(k),k=1,nomin(/2))
  98. C     WRITE(IOIMP,*) 'leurs duales     ' ,(nodua(k),k=1,nomin(/2))
  99.  
  100.       ncomp = nomin(/2)
  101.       segini iccoun
  102.  
  103.       do 2000 ic = 1,ncomp
  104.          segini iicpr
  105.  
  106.          iccoun(ic) = iicpr
  107. C      WRITE(IOIMP,*) ' composante et  son iicpr ',ic,iicpr
  108.  2000 continue
  109.  
  110.       ntplx = 0
  111. C  quels sont les noeuds concernes par des liaisons
  112.       do 1700 i=1,IRIGEL(/2)
  113.          MELEME=IRIGEL(1,I)
  114.          SEGACT MELEME
  115.          ipt4=meleme
  116.          descr = irigel(3,i)
  117.          segact descr
  118.          xmatri= irigel(4,i)
  119.          segact xmatri
  120.          if (lisinc(/2).le.1) goto 1701
  121.          nomm = lisinc(2)
  122. C                  on  l identifie par un numero ipo
  123. C              pour recuperer les composantes ad hoc
  124.  
  125. C  quelle est sa position dans nomin
  126.  
  127.          do 3634 ipo=1,nomin(/2)
  128.             if(NOMM.eq.nomin(ipo)) goto 3635
  129.  3634    continue
  130.  3635    continue
  131. C recup et comptage des noeuds supports de multiplicateurs
  132.          ideb=2
  133.          iicpr = iccoun(ipo)
  134.          do 1703 iel=1,num(/2)
  135. *         xmatri=imattt(iel)
  136. *         segact xmatri
  137.             ip =num(noelep(ideb),iel)
  138. *        WRITE(IOIMP,*) ' remplissage ip icpr(ip) ',ip,num(1,iel)
  139.             icpr(ip)=num(1,iel)
  140.             iinb = iinb+1
  141.             ivers(iinb)= ip
  142.             cvers(iinb)= re(1,2,iel)*coerig(i)
  143.             ntplx = ntplx+1
  144. *      WRITE(IOIMP,*) 'ip icpr(ip)  ipo' ,ip,icpr(ip),ipo
  145. *         segdes xmatri
  146.  1703    continue
  147.  1701    continue
  148.          segdes descr,xmatri
  149.  1700 continue
  150.  
  151. *       WRITE(IOIMP,*) ' nombre de pts supports de LX ' ,ntplx
  152. C---------------------------------------------------------
  153. *       WRITE(IOIMP,*) 'ivers ' ,(ivers(k),k=1,iinb)
  154. C    on ouvre le chpoint des reactions calculees par KU-F
  155.       mchpoi = ipchp1
  156.       segact mchpoi
  157.       nsoup1 = ipchp(/1)
  158.  
  159.  
  160. C     initialisation du chpo de sortie support de ntplx points
  161.       nat=1
  162.       nsoupo = 1
  163.       segini mchpo1
  164.       ipchp2= mchpo1
  165.       mchpo1.jattri(1) = 1
  166.       mchpo1.ifopoi= ifopoi
  167.       mchpo1.mochde='CHAMP DE LX ISSU DE REMPLX'
  168.       mchpo1.mtypoi='REMPLX'
  169.  
  170.       nc= 1
  171.       segini msoup1
  172.       mchpo1.ipchp(1)=msoup1
  173. C
  174.       nbelem = ntplx
  175.       nbnn = 1
  176.       nbref = 0
  177.       nbsous=0
  178.       segini meleme
  179.       msoup1.igeoc =meleme
  180.       ipt1=meleme
  181.       itypel= 1
  182.  
  183.       n = ntplx
  184.       msoup1.nocomp(1) = 'LX  '
  185.       msoup1.noharm(1)= ifo
  186.       segini mpova1
  187.       msoup1.ipoval = mpova1
  188.  
  189.       inpp = 0
  190.       do 1000 isous=1,nsoup1
  191.          msoupo= ipchp(isous)
  192.          segact msoupo
  193.          meleme = igeoc
  194.          segact meleme
  195.          nc = nocomp(/2)
  196.          mpoval=ipoval
  197.          segact mpoval
  198.          nptc = vpocha(/1)
  199.          do 1010 icomp=1,nc
  200.             nom2= nocomp(icomp)
  201. C    recherche de l inconnue  duale
  202.             do 334 ipo=1,nomin(/2)
  203. *       WRITE(IOIMP,*) ' nom de la composante et nodua ',nom2,NODUA(ipo)
  204.                if(NOM2.eq.NODUA(ipo)) goto 335
  205.  334        continue
  206. C    ce n est pas une composante depedante
  207.             goto 1009
  208.  335        continue
  209. C      WRITE(IOIMP,*) 'composante ->vpocha(1) ipo ' ,nom2 ,nptc,ipo
  210.             iicpr = iccoun(ipo)
  211. C    boucle sur les noeuds
  212. C      WRITE(IOIMP,*) ' composante et  son iicpr nbre ii ',ipo,iicpr,iinb
  213.             segini siver2
  214. C       WRITE(IOIMP,*) 'num(1,il)',(num(1,il),il=1,nptc)
  215.  
  216. C ****************************************************
  217. C [-DAVID-22/07/2004-] Inversion du tableau num suppression de la boucle 520
  218. *        do 500 k=1,iinb
  219. *        ip = ivers(k)
  220. *        do 520 lk=1,nptc
  221. *         if(ip.eq.num(1,lk)) then
  222. *         iver2(lk)=ip
  223. *         cver2(lk)=cvers(k)
  224. *         goto 500
  225. *         endif
  226. *520     continue
  227. *500     continue
  228.             do lk = 1, nptc
  229.                if ((num(1,lk).ge.1).and.(num(1,lk).le.nbpts)) then
  230.                   invnum(num(1,lk))=lk
  231.                endif
  232.             enddo
  233.             do 500 k=1,iinb
  234.                ip = ivers(k)
  235.                lk = invnum(ip)
  236.                if ((lk.ge.1).and.(lk.le.nptc)) then
  237.                   iver2(lk)=ip
  238.                   cver2(lk)=cvers(k)
  239.                endif
  240.  500        continue
  241.  
  242. C       WRITE(IOIMP,*) 'iver2 ' ,(iver2(k),k=1,nptc)
  243.  
  244.             do 1020 j=1,nptc
  245.                ip = iver2(j)
  246.                if(ip.eq.0) goto 1020
  247.                if(icpr(ip).eq.0.or.iver2(j).eq.0) goto 1020
  248. *   on ne dicise plus par deux puisque simple multiplicateur
  249.                xfo=-vpocha(j,icomp)/1.D0/cver2(j)
  250. *       WRITE(IOIMP,*) ' ip inpp icpr    ',ip,inpp,icpr(ip)
  251.                ipt1.num(1,inpp+1) = abs(icpr(ip))
  252. *  pour avoir les LX au total
  253.                icpr(ip)=-abs(icpr(ip))
  254.                mpova1.vpocha(inpp+1,1)=xfo
  255. C       WRITE(IOIMP,*) 'ip icpr xfo ',ip,icpr(ip),
  256. C    &  xfo,lk,(inpp+1)
  257.                inpp = inpp+1
  258.  1020       continue
  259.             segsup siver2
  260.  1009       continue
  261.  1010    continue
  262.  1000 continue
  263. *  on complete les LX
  264.       do 1022 ic=1,nomin(/2)
  265.          iicpr = iccoun(ic)
  266.          do 1021 j=1,icpr(/1)
  267.             if (icpr(j).le.0) goto 1021
  268. *       WRITE(IOIMP,*) ' complete j icpr(j) inpp num(/2) ',
  269. *    >        j,icpr(j),inpp,ipt1.num(/2)
  270.             ipt1.num(1,inpp+1) = icpr(j)
  271.             inpp=inpp+1
  272.  1021    continue
  273.  1022 continue
  274. *        WRITE(IOIMP,*) ' on a ecrit ',inpp, ' LX'
  275.       nbnn=ipt1.num(/1)
  276.       nbelem=inpp
  277.       nbsous=0
  278.       nbref=0
  279. *       WRITE(IOIMP,*) ' num mpova1 ',ipt1.num(/2),mpova1.vpocha(/1)
  280.       if (nbelem.ne.ipt1.num(/2)) then
  281. *        WRITE(IOIMP,*) ' remplx ajustement LX '
  282.          segadj ipt1
  283.          n=nbelem
  284.          nc=1
  285.          segadj mpova1
  286.       endif
  287.  
  288.       do 3000 ic=1,nomin(/2)
  289.          iicpr = iccoun(ic)
  290.          segsup iicpr
  291.  3000 continue
  292.       segsup iccoun,snomin,snomdu
  293.       segdes mrigid
  294.       END
  295.  
  296.  
  297.  

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