Télécharger la plaquette Cast3M


fr en

Télécharger rigeli.eso

Retour à la liste

Numérotation des lignes : 

rigeli

  1. C RIGELI    SOURCE    MB234859  25/01/03    21:15:28     12105          
  2.       SUBROUTINE RIGELI(IPRIG0,IPMAS0,IPAMO0,IPRIGI,IPMASS,IPAMOR,
  3.      &                                       IDEMEM,IDEME0,IDEME1,IELIM)
  4.  
  5.       IMPLICIT INTEGER(I-N)
  6.  
  7. ************************************************************************
  8. *
  9. *                            R I G E L I
  10. *                            -----------
  11. *
  12. *
  13. * FONCTION:
  14. * ---------
  15. *
  16. *     elimination des relations sur la matrice de ridigite
  17. *     + inconnues liees sur les autres matrices
  18. *
  19. *     note: le code est extrait de resou.eso
  20. *     on y ajoute la gestion (eventuelle) d autres matrices en parallele  
  21. *
  22. *
  23. * CREATION et MODIFICATION:
  24. * ------------------------
  25.  
  26. *     PASCAL BOUDA, 4 SEPTEMBRE 2020
  27. *
  28. ************************************************************************
  29.  
  30. -INC PPARAM
  31. -INC CCOPTIO
  32. -INC SMRIGID
  33. -INC SMELEME
  34.  
  35. *----------------------------------------------------------------------*
  36.       CHARACTER*4  NOHR(1)
  37.       INTEGER*4 IOHR
  38.       EQUIVALENCE(IOHR,NOHR)
  39.       LOGICAL bdblx
  40.  
  41.       POINTEUR  RIEL1.MRIGID,RIEL2.MRIGID,RIEL3.MRIGID
  42. *----------------------------------------------------------------------*
  43. *Initialisations (cf resou.eso)
  44.       IGRADJ=0
  45.       IUNIL=0 
  46.       NOUNIL=1 
  47.       IDEPE=0 
  48.       IMTVID=0
  49. *Nombre de passes max-1
  50.       NELIM=2
  51.       NOEN=1
  52. *----------------------------------------------------------------------*
  53. *  verification pas de blocage en double
  54.       CALL VERLAG(IPRIG0)
  55.       if (ierr.ne.0) return
  56. *----------------------------------------------------------------------*
  57. *Copie avant debut du travail 
  58.       MRIGID=IPRIG0
  59.       segact mrigid
  60.       if (jrcond.ne.0) nelim=30
  61.       SEGINI,RIEL1=MRIGID
  62.       SEGDES RIEL1
  63.       IPRIGI=RIEL1
  64. *Copie des matrices auxiliaires
  65.       RIEL2=0
  66.       RIEL3=0
  67.       IPMASS=0
  68.       IPAMOR=0      
  69.       IF (IPMAS0.NE.0) THEN
  70.          MRIGID=IPMAS0
  71.          SEGINI,RIEL2=MRIGID
  72.          SEGACT RIEL2*MOD
  73.          RIEL2.MTYMAT='TEMPORAI'
  74.          SEGDES RIEL2
  75.          IPMASS=RIEL2
  76.       ENDIF
  77.       IF (IPAMO0.NE.0) THEN
  78.          MRIGID=IPAMO0
  79.          SEGINI,RIEL3=MRIGID
  80.          SEGACT RIEL3*MOD
  81.          RIEL3.MTYMAT='TEMPORAI'
  82.          SEGDES RIEL3
  83.          IPAMOR=RIEL3
  84.       ENDIF
  85. *----------------------------------------------------------------------*
  86. * On sort si la premiere matrice n'est pas de sstype RIGIDITE (i.e. matrice deja eliminee
  87.       MRIGID=IPRIGI 
  88.       SEGACT MRIGID*MOD
  89.       IF (MRIGID.MTYMAT.NE.'RIGIDITE') RETURN
  90.       MRIGID.MTYMAT='TEMPORAI'
  91. *----------------------------------------------------------------------*      
  92. * On verifie qu hormis les matrices en 'noharm', 
  93. * toutes les matrices avec mode de fourier on le mm numero
  94.       nohr='NOHA'
  95.       IIF1=IRIGEL(5,1)
  96.       IIFOUR=IIF1
  97.       DO I=1,IRIGEL(/2)-1
  98.          IIF2=IRIGEL(5,I+1)
  99.          DIIF=IIF2-IIF1
  100.          IF ((DIIF.NE.0).AND.(IIF1.NE.IOHR.AND.IIF2.NE.IOHR)) THEN
  101.             CALL ERREUR(324)
  102.          ELSE
  103.             IF (IIF1.NE.IOHR) IIFOUR=IIF1
  104.             IF (IIF2.NE.IOHR) IIFOUR=IIF2
  105.          ENDIF
  106.       IIF1=IIF2
  107.       END DO
  108.       DO I=1,MRIGID.IRIGEL(/2)
  109.          MRIGID.IRIGEL(5,I)=IIFOUR
  110.       ENDDO
  111.       SEGDES MRIGID
  112. *----------------------------------------------------------------------*
  113. *     debut du travail delimination (cf resou.eso)
  114. *  y a t il des matrices de relations non unilaterales
  115.       segact mrigid
  116.       nrige= irigel(/1)
  117.       idepe=0
  118.       nbr = irigel(/2)
  119.       do 1000 irig = 1,nbr
  120.        meleme=irigel(1,irig)
  121.        segact meleme
  122.        if ((irigel(6,irig).eq.0.or.nounil.eq.1).and.itypel.eq.22)
  123.      >    idepe=idepe+num(/2)
  124.        if (irigel(6,irig).ne.0) iunil=1
  125.        if (irigel(7,1).ne.0) insym=1
  126. 1000  continue
  127. *  elimination recursive des conditions aux limites
  128. *  on la fait en gradient conjugue ou en appel de unilater
  129.       nfois=nelim-1
  130.       if (igradj.eq.1.or.(iunil.eq.1.and.nounil.eq.0)) nfois=29
  131.       bdblx=.false.
  132.       imult=1
  133.       icond=idepe
  134.       icondi=icond+1
  135.       IELIM=0
  136.       do ifois=1,nfois
  137.       if(imult.ne.0.and.icond.ne.0.and.
  138.      >      (icondi-icond.gt.0.or.igradj.eq.1)) then
  139.        icondi=icond
  140.        IELIM=IELIM+1
  141.        if(ierr.ne.0) return
  142.        call resouc(mrigid,mrigic,idemem,ideme0,ideme1,
  143.      >       nounil,bdblx,icond,imult,IELIM,imtvid,nelim)
  144. **     write(6,*) ' passe ',if,' condition ',icond
  145.        ri1=mrigic
  146.        segact ri1
  147. **     write(6,*) 'rigeli ri1 ichole',ri1,ri1.ichole
  148.        if(ierr.ne.0) return
  149. *----------------------------------------------------------------------*
  150. *Elimination (eventuelle) en parallele sur les autres matrices
  151.       IF (ICONDI.GT.ICOND) THEN  
  152.          CALL RIGEL2(MRIGID,RIEL2)
  153.          IF(IERR.NE.0) RETURN
  154.          CALL RIGEL2(MRIGID,RIEL3)
  155.          IF(IERR.NE.0) RETURN
  156.       ENDIF
  157. *----------------------------------------------------------------------*
  158.       mrigid=mrigic
  159.       endif
  160.       enddo
  161. *  Si on n'a pas reussi a tout eliminer, on fait encore une passe pour creer lagdua
  162.       if (iunil.eq.0.or.nounil.eq.1) then
  163.       if (icond.ne.0) then
  164.        IELIM=IELIM+1
  165.       ICONDI=ICOND
  166.           bdblx=.true.
  167.        if(ierr.ne.0) return
  168.         call resouc(mrigid,mrigic,idemem,ideme0,ideme1,
  169.      >        nounil,bdblx,icond,imult,IELIM,imtvid,nelim)
  170. **     write(6,*) ' passe ','finale',' condition ',icond
  171.       if(ierr.ne.0) return
  172. *----------------------------------------------------------------------*
  173. *Elimination (eventuelle) en parallele sur les autres matrices
  174.       IF (ICONDI.GT.ICOND) THEN 
  175.          CALL RIGEL2(MRIGID,RIEL2)
  176.          IF(IERR.NE.0) RETURN
  177.          CALL RIGEL2(MRIGID,RIEL3)
  178.          IF(IERR.NE.0) RETURN
  179.       ENDIF
  180. *----------------------------------------------------------------------*
  181.       mrigid=mrigic
  182.       endif
  183.       endif
  184. **     write (6,*) 'nombre de passes',if
  185.       if (idepe.ne.0) noid = 1
  186. *----------------------------------------------------------------------*
  187. *Mise au propre (triangularisation via nbinc) + sauvegarde des matrices eliminees
  188.       IPRIGI=MRIGID
  189.       CALL NBINC(IPRIGI,NR)
  190.       IF(IERR.NE.0) RETURN  
  191.       IF (IPMASS.NE.0) THEN
  192.          IPMASS=RIEL2
  193.          CALL NBINC(IPMASS,NM)
  194.          IF(IERR.NE.0) RETURN
  195.       ENDIF
  196.       IF (IPAMOR.NE.0) THEN
  197.          IPAMOR=RIEL3
  198.          CALL NBINC(IPAMOR,NA)
  199.          IF(IERR.NE.0) RETURN
  200.       ENDIF 
  201. *----------------------------------------------------------------------*
  202. *      call prrigi(IPRIGI,1)
  203.       END
  204.  
  205.  
  206.  
  207.  
  208.  
  209.  

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