Télécharger la plaquette Cast3M


fr en

Télécharger redfor.eso

Retour à la liste

Numérotation des lignes : 

redfor

  1. C REDFOR    SOURCE    CB215821  20/11/25    13:38:49     10792          
  2.       subroutine redfor(mchpoi,ri4,mchpo1)
  3.  
  4. *  élimination des ddls supprimés dans le second membre réduit
  5. * inspiré de transr et mschp1 (MASQ)
  6. *     mchpoi : entree = second membre réduit avec ddls supprimés
  7. *     ri4    : entree = matrice de relation
  8. *     mchpo1 : sortie = second membre réduit sans ddls supprimés
  9.  
  10.       IMPLICIT INTEGER(I-N)
  11.       IMPLICIT REAL*8 (A-H,O-Z)
  12.  
  13. -INC SMCHPOI
  14. -INC SMRIGID
  15. -INC PPARAM
  16. -INC CCOPTIO
  17. -INC CCHAMP
  18. -INC SMCOORD
  19. -INC SMELEME
  20. -INC TMTRAV
  21.  
  22.       SEGMENT/MTRA/(NOPOIN(nbpts))
  23.  
  24.       SEGMENT MTR1
  25.         CHARACTER*(LOCOMP) IPCOM(0)
  26.       ENDSEGMENT
  27.  
  28.       SEGMENT/MTR4/(IPHAR(0))
  29.  
  30.       CHARACTER*(LOCOMP) nomp,nomd
  31.  
  32.       SEGINI MTRA,MTR1,MTR4
  33. *
  34. * Initialisation de MTRAV, MTRA, MTR1, MTR4 (repris de mschp1.eso)
  35. *
  36.       SEGACT MCHPOI
  37.       IK=0
  38.       NSOUPO=IPCHP(/1)
  39.       DO 20 IA=1,NSOUPO
  40.          MSOUPO=IPCHP(IA)
  41.          SEGACT MSOUPO
  42.          MELEME=IGEOC
  43.          SEGACT MELEME
  44.          NBELEM=NUM(/2)
  45.          DO 30 IB=1,NBELEM
  46.             K=NUM(1,IB)
  47.             IF(NOPOIN(K).NE.0) GO TO 30
  48.             IK=IK+1
  49.             NOPOIN(K)=IK
  50.  30      CONTINUE
  51.          NCBBB=NOCOMP(/2)
  52.          DO 40 IB=1,NCBBB
  53.             NC=IPCOM(/2)
  54.             DO 50 IC=1,NC
  55.                IF(IPCOM(IC).NE.NOCOMP(IB)) GO TO 50
  56.                IF(IPHAR(IC).EQ.NOHARM(IB)) GO TO 40
  57.  50         CONTINUE
  58.             IPCOM(**)=NOCOMP(IB)
  59.             IPHAR(**)=NOHARM(IB)
  60.  40      CONTINUE
  61.  20   CONTINUE
  62. C
  63.       NNIN=IPCOM(/2)
  64.       NNNOE=IK
  65.       SEGINI MTRAV
  66.       DO 70 IA=1,NNIN
  67.          INCO(IA)=IPCOM(IA)
  68.          NHAR(IA)=IPHAR(IA)
  69.  70   CONTINUE
  70. C
  71. C CREATION DE BB,IBIN,IGEO
  72. C
  73.       NSOUPO=IPCHP(/1)
  74.       DO 80 IA=1,NSOUPO
  75.          MSOUPO=IPCHP(IA)
  76.          SEGACT MSOUPO
  77.          MELEME=IGEOC
  78.          MPOVAL=IPOVAL
  79.          SEGACT MELEME,MPOVAL
  80.          NBELEM=NUM(/2)
  81.          NC=VPOCHA(/2)
  82.          NC1=NOCOMP(/2)
  83. C
  84.          DO 90 IB=1,NC1
  85.             DO 100 IC=1,NNIN
  86.                IF(NOCOMP(IB).NE.IPCOM(IC)) GO TO 100
  87.                IF(NOHARM(IB).EQ.IPHAR(IC)) GO TO 110
  88.  100        CONTINUE
  89. * Pas de composante trouvée, ce n'est pas normal
  90.             goto 9999
  91.  110        CONTINUE
  92.             DO 120 ID=1,NBELEM
  93.                KI=NOPOIN(NUM(1,ID))
  94.                IGEO(KI)=NUM(1,ID)
  95.                IBIN(IC,KI)=1
  96.                BB(IC,KI)=VPOCHA(ID,IB)
  97.  120        CONTINUE
  98.  90      CONTINUE
  99.  80   CONTINUE
  100.  
  101. *  on balaye les raideurs de dependances, on supprime les ddl dependants
  102. *  dans le MTRAV
  103.       segact ri4
  104.       do 1100 irig=1,ri4.irigel(/2)
  105.          if (ri4.irigel(8,irig).ne.0) then
  106.             descr=ri4.irigel(3,irig)
  107.             meleme=ri4.irigel(1,irig)
  108.             Xmatri=ri4.irigel(4,irig)
  109.             segact descr,meleme,xmatri
  110.             do 1110 iligrp=1,lisinc(/2)
  111.                if (lisinc(iligrp).eq.'LX  ') goto 1120
  112.  1110       continue
  113.             goto 1100
  114.  1120       continue
  115. * Le multiplicateur de lagrange n'est pas en première position
  116. * dans le descripteur de la matrice, ce n'est pas prévu
  117.             if (iligrp.ne.1) goto 9999
  118.             nbelem=num(/2)
  119. * on supprime le multiplicateur de lagrange et le ddl dépendant
  120.             do idep=1,2
  121.                nomp=lisinc(idep)
  122. * on trouve le nom dual correspondant (si non trouvé dual=primal)
  123.                nomd=nomp
  124.                do ipri=1,lnomdd
  125.                   if (nomp.eq.nomdd(ipri)) nomd=nomdu(ipri)
  126.                enddo
  127.                iharm=ri4.irigel(5,irig)
  128.                inin=0
  129.                do ii=1,nhar(/1)
  130.                   if (inco(ii).eq.nomd.and.nhar(ii).eq.iharm) inin=ii
  131.                enddo
  132.                if (inin.ne.0) then
  133.                   do 1130 i=1,nbelem
  134. *               write(ioimp,*) 'ddl a eliminer ',iharm,nomd,' ',
  135. *     $                    num(noelep(idep),i)
  136.                      ik=nopoin(num(noelep(idep),i))
  137.                      if (ik.ne.0) ibin(inin,ik)=0
  138.  1130             continue
  139.                endif
  140.             enddo
  141.             segdes descr,meleme,xmatri
  142.          endif
  143.  1100 continue
  144.       segdes ri4
  145.       segsup MTRA,MTR1,MTR4
  146. *
  147. * On reconstruit le chpoint nettoyé et on lui donne les mêmes
  148. * caractéristiques que l'original
  149. *
  150.       CALL CRECHP(mtrav,mchpo1)
  151.       segsup mtrav
  152.       mchpo1.mochde='CHPOINT cree par redfor'
  153.       mchpo1.ifopoi=ifopoi
  154.       do i=1,min(mchpo1.jattri(/1),jattri(/1))
  155.          mchpo1.jattri(i)=jattri(i)
  156.       enddo
  157.       return
  158.  
  159.  9999 continue
  160.       MOTERR='REDFOR  '
  161.       CALL ERREUR(1039)
  162.       RETURN
  163.       end
  164.  
  165.  

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