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    PV        22/02/02    21:15:02     11277          
  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.  
  40.       POINTEUR  RIEL1.MRIGID,RIEL2.MRIGID,RIEL3.MRIGID
  41. *----------------------------------------------------------------------*
  42. *Initialisations (cf resou.eso)
  43.       IGRADJ=0
  44.       IUNIL=0 
  45.       NOUNIL=1 
  46.       IDEPE=0 
  47.       IMTVID=0
  48. *Nombre de passes max-1
  49.       NELIM=2
  50.       NOEN=1
  51. *----------------------------------------------------------------------*
  52. *  verification pas de blocage en double
  53.       CALL VERLAG(IPRIG0)
  54.       if (ierr.ne.0) return
  55. *----------------------------------------------------------------------*
  56. *Copie avant debut du travail 
  57.       MRIGID=IPRIG0
  58.       segact mrigid
  59.       if (jrcond.ne.0) nelim=30
  60.       SEGINI,RIEL1=MRIGID
  61.       SEGDES RIEL1
  62.       IPRIGI=RIEL1
  63. *Copie des matrices auxiliaires
  64.       RIEL2=0
  65.       RIEL3=0
  66.       IPMASS=0
  67.       IPAMOR=0      
  68.       IF (IPMAS0.NE.0) THEN
  69.          MRIGID=IPMAS0
  70.          SEGINI,RIEL2=MRIGID
  71.          SEGACT RIEL2*MOD
  72.          RIEL2.MTYMAT='TEMPORAI'
  73.          SEGDES RIEL2
  74.          IPMASS=RIEL2
  75.       ENDIF
  76.       IF (IPAMO0.NE.0) THEN
  77.          MRIGID=IPAMO0
  78.          SEGINI,RIEL3=MRIGID
  79.          SEGACT RIEL3*MOD
  80.          RIEL3.MTYMAT='TEMPORAI'
  81.          SEGDES RIEL3
  82.          IPAMOR=RIEL3
  83.       ENDIF
  84. *----------------------------------------------------------------------*
  85. * On sort si la premiere matrice n'est pas de sstype RIGIDITE (i.e. matrice deja eliminee
  86.       MRIGID=IPRIGI 
  87.       SEGACT MRIGID*MOD
  88.       IF (MRIGID.MTYMAT.NE.'RIGIDITE') RETURN
  89.       MRIGID.MTYMAT='TEMPORAI'
  90. *----------------------------------------------------------------------*      
  91. * On verifie qu hormis les matrices en 'noharm', 
  92. * toutes les matrices avec mode de fourier on le mm numero
  93.       nohr='NOHA'
  94.       IIF1=IRIGEL(5,1)
  95.       IIFOUR=IIF1
  96.       DO I=1,IRIGEL(/2)-1
  97.          IIF2=IRIGEL(5,I+1)
  98.          DIIF=IIF2-IIF1
  99.          IF ((DIIF.NE.0).AND.(IIF1.NE.IOHR.AND.IIF2.NE.IOHR)) THEN
  100.             CALL ERREUR(324)
  101.          ELSE
  102.             IF (IIF1.NE.IOHR) IIFOUR=IIF1
  103.             IF (IIF2.NE.IOHR) IIFOUR=IIF2
  104.          ENDIF
  105.       IIF1=IIF2
  106.       END DO
  107.       DO I=1,MRIGID.IRIGEL(/2)
  108.          MRIGID.IRIGEL(5,I)=IIFOUR
  109.       ENDDO
  110.       SEGDES MRIGID
  111. *----------------------------------------------------------------------*
  112. *     debut du travail delimination (cf resou.eso)
  113. *  y a t il des matrices de relations non unilaterales
  114.       segact mrigid
  115.       nrige= irigel(/1)
  116.       idepe=0
  117.       nbr = irigel(/2)
  118.       do 1000 irig = 1,nbr
  119.        meleme=irigel(1,irig)
  120.        segact meleme
  121.        if ((irigel(6,irig).eq.0.or.nounil.eq.1).and.itypel.eq.22)
  122.      >    idepe=idepe+num(/2)
  123.        if (irigel(6,irig).ne.0) iunil=1
  124.        if (irigel(7,1).ne.0) insym=1
  125. 1000  continue
  126. *  elimination recursive des conditions aux limites
  127. *  on la fait en gradient conjugue ou en appel de unilater
  128.       nfois=nelim-1
  129.       if (igradj.eq.1.or.(iunil.eq.1.and.nounil.eq.0)) nfois=29
  130.       lagdua=0
  131.       imult=1
  132.       icond=idepe
  133.       icondi=icond+1
  134.       IELIM=0
  135.       do ifois=1,nfois
  136.       if(imult.ne.0.and.icond.ne.0.and.
  137.      >      (icondi-icond.gt.0.or.igradj.eq.1)) then
  138.        icondi=icond
  139.        lagdua=-1
  140.        IELIM=IELIM+1
  141.        if(ierr.ne.0) return
  142.        call resouc(mrigid,mrigic,idemem,ideme0,ideme1,
  143.      >       nounil,lagdua,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.       lagdua=0
  163.       if (iunil.eq.0.or.nounil.eq.1) then
  164.       if (icond.ne.0) then
  165.        IELIM=IELIM+1
  166.       ICONDI=ICOND
  167.        if(ierr.ne.0) return
  168.         call resouc(mrigid,mrigic,idemem,ideme0,ideme1,
  169.      >        nounil,lagdua,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.  

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