Télécharger la plaquette Cast3M


fr en

Télécharger relr1b.eso

Retour à la liste

Numérotation des lignes : 

relr1b

  1. C RELR1B    SOURCE    GOUNAND   11/05/24    21:16:00     6976
  2.       SUBROUTINE RELR1B(DDDNUL,
  3.      $     MINCP,KRSPGP,KRINCP,
  4.      $     MEL,DES,
  5.      $     PMCOU,
  6.      $     IMPR,IRET)
  7.       IMPLICIT REAL*8 (A-H,O-Z)
  8.       IMPLICIT INTEGER (I-N)
  9. C***********************************************************************
  10. C NOM         : RELR1B
  11. C DESCRIPTION :
  12. *   construction de la correspondance :
  13. *   ieme ddl dual de la matrice assemblée <->
  14. *   (numéros des ddl primaux avec lesquels il est
  15. *   en relation). C'est le profil morse (non ordonné)
  16. C
  17. C
  18. C
  19. C LANGAGE     : ESOPE
  20. C AUTEUR      : Stéphane GOUNAND (CEA/DEN/DM2S/SFME/LTMF)
  21. C               mél : gounand@semt2.smts.cea.fr
  22. C***********************************************************************
  23. C APPELES          :
  24. C APPELES (E/S)    :
  25. C APPELES (BLAS)   :
  26. C APPELES (CALCUL) :
  27. C APPELE PAR       : RELR14
  28. C***********************************************************************
  29. C SYNTAXE GIBIANE    :
  30. C ENTREES            :
  31. C ENTREES/SORTIES    :
  32. C SORTIES            :
  33. C CODE RETOUR (IRET) : = 0 si tout s'est bien passé
  34. C***********************************************************************
  35. C VERSION    : v1, 30/06/2003, version initiale
  36. C HISTORIQUE : v1, 30/06/2003, création
  37. C HISTORIQUE :
  38. C HISTORIQUE :
  39. C***********************************************************************
  40. C Prière de PRENDRE LE TEMPS de compléter les commentaires
  41. C en cas de modification de ce sous-programme afin de faciliter
  42. C la maintenance !
  43. C***********************************************************************
  44.  
  45. -INC PPARAM
  46. -INC CCOPTIO
  47. -INC SMRIGID
  48.       POINTEUR DES.DESCR
  49. -INC SMELEME
  50.       POINTEUR MEL.MELEME
  51. * Includes persos
  52. CBEGININCLUDE SMMINC
  53.       SEGMENT MINC
  54.       INTEGER     NPOS(NPT+1)
  55.       INTEGER     MPOS(NPT,NBI+1)
  56.       ENDSEGMENT
  57.       SEGMENT IMINC
  58.       INTEGER LNUPO (NDDL)
  59.       INTEGER LNUINC(NDDL)
  60.       ENDSEGMENT
  61. CENDINCLUDE SMMINC
  62.       POINTEUR MINCP.MINC
  63. CBEGININCLUDE SMPMORS
  64.       SEGMENT PMORS
  65.       INTEGER IA (NTT+1)
  66.       INTEGER JA (NJA)
  67.       ENDSEGMENT
  68. CENDINCLUDE SMPMORS
  69.       POINTEUR PMCOU.PMORS
  70. *     Segment LSTIND (liste séquentielle indexée)
  71.       SEGMENT LSTIND
  72.       INTEGER IDX(NBM+1)
  73.       INTEGER IELRIG(NBTVAL)
  74.       INTEGER ILIGR (NBTVAL)
  75.       ENDSEGMENT
  76.       POINTEUR DDDNUL.LSTIND
  77. *
  78. -INC SMLENTI
  79.       POINTEUR KRSPGP.MLENTI
  80.       POINTEUR KRINCP.MLENTI
  81.       POINTEUR IWORK.MLENTI
  82.       POINTEUR DDDNOP.MLENTI
  83. *
  84.       INTEGER IMPR,IRET
  85. *
  86. * Executable statements
  87. *
  88.       IF (IMPR.GT.2) WRITE(IOIMP,*) 'Entrée dans relr1b.eso'
  89.       NPOPRI=MINCP.NPOS(/1)-1
  90.       NDDLPR=MINCP.NPOS(NPOPRI+1)-1
  91.       SEGACT DDDNUL
  92.       NDDLDU=DDDNUL.IDX(/1)-1
  93. *a effacer     NEL=MEL.NUM(/2)
  94.       NDDLOP=DES.NOELEP(/1)
  95. *a effacer      NDDLOD=DES.NOELED(/1)
  96. *  Segment de travail
  97.       JG=NDDLPR
  98.       SEGINI IWORK
  99. *
  100. *   Passe 1 : construction de la correspondance :
  101. *             ieme ddl dual  <-> nombre des ddls
  102. *                                primaux avec lesquels
  103. *                                il est en relation
  104. *             DDDNOP
  105. *
  106.       JG=NDDLDU
  107.       SEGINI DDDNOP
  108.       DO IDDLDU=1,NDDLDU
  109.          LDG=0
  110. * Fin de la liste chaînée
  111.          LAST=-1
  112.          DO JDX=DDDNUL.IDX(IDDLDU),
  113.      $          DDDNUL.IDX(IDDLDU+1)-1
  114.             IELEM =DDDNUL.IELRIG(JDX)
  115. * a effacer           ILIGRD=DDDNUL.ILIGR(JDX)
  116.             DO ILIGRP=1,NDDLOP
  117.                IPO=KRSPGP.LECT(MEL.NUM(DES.NOELEP(ILIGRP),IELEM))
  118.                IINC=KRINCP.LECT(ILIGRP)
  119.                IPOS=MINCP.MPOS(IPO,IINC)
  120.                IF (IPOS.EQ.0) THEN
  121.                   WRITE(IOIMP,*) 'Erreur grave no1'
  122.                   GOTO 9999
  123.                ENDIF
  124.                IDDLPR=MINCP.NPOS(IPO)+IPOS-1
  125.                IF (IWORK.LECT(IDDLPR).EQ.0) THEN
  126.                   LDG=LDG+1
  127.                   IWORK.LECT(IDDLPR)=LAST
  128.                   LAST=IDDLPR
  129.                ENDIF
  130.             ENDDO
  131.          ENDDO
  132. *     Le nombre de points distincts trouvés est:
  133.          DDDNOP.LECT(IDDLDU)=LDG
  134. *     On remet la liste chaînée à 0
  135.          DO ILDG=1,LDG
  136.             IPREC=IWORK.LECT(LAST)
  137.             IWORK.LECT(LAST)=0
  138.             LAST=IPREC
  139.          ENDDO
  140.       ENDDO
  141. *
  142. *   Passe 2 : construction de la correspondance :
  143. *             ieme ddl dual de la matrice assemblée <->
  144. *             (numéros des ddl primaux avec lesquels il est
  145. *             en relation). C'est le profil morse (non ordonné)
  146. *             PMCOU
  147. *
  148. *
  149.       NTT=NDDLDU
  150.       NJA=0
  151.       SEGINI PMCOU
  152.       IDEPA=1
  153.       DO IDDLDU=1,NDDLDU
  154.          PMCOU.IA(IDDLDU)=IDEPA
  155.          IDEPA=IDEPA+DDDNOP.LECT(IDDLDU)
  156.       ENDDO
  157.       PMCOU.IA(NDDLDU+1)=IDEPA
  158.       SEGSUP DDDNOP
  159.       NJA=IDEPA-1
  160.       SEGADJ PMCOU
  161.       DO IDDLDU=1,NDDLDU
  162.          KDX=PMCOU.IA(IDDLDU)-1
  163.          DO JDX=DDDNUL.IDX(IDDLDU),
  164.      $          DDDNUL.IDX(IDDLDU+1)-1
  165.             IELEM =DDDNUL.IELRIG(JDX)
  166. * a effacer           ILIGRD=DDDNUL.ILIGR(JDX)
  167.             DO ILIGRP=1,NDDLOP
  168.                IPO=KRSPGP.LECT(MEL.NUM(DES.NOELEP(ILIGRP),IELEM))
  169.                IINC=KRINCP.LECT(ILIGRP)
  170.                IPOS=MINCP.MPOS(IPO,IINC)
  171.                IF (IPOS.EQ.0) THEN
  172.                   WRITE(IOIMP,*) 'Erreur grave no2'
  173.                   GOTO 9999
  174.                ENDIF
  175.                IDDLPR=MINCP.NPOS(IPO)+IPOS-1
  176.                IF (IWORK.LECT(IDDLPR).EQ.0) THEN
  177.                   KDX=KDX+1
  178.                   PMCOU.JA(KDX)=IDDLPR
  179.                   IWORK.LECT(IDDLPR)=KDX
  180.                ENDIF
  181.             ENDDO
  182.          ENDDO
  183. *     On remet le segment de travail a zero
  184.          DO KDX=PMCOU.IA(IDDLDU),PMCOU.IA(IDDLDU+1)-1
  185.             IWORK.LECT(PMCOU.JA(KDX))=0
  186.          ENDDO
  187.       ENDDO
  188.       SEGDES PMCOU
  189.       SEGSUP IWORK
  190.       SEGDES DDDNUL
  191. *
  192. * Normal termination
  193. *
  194.       IRET=0
  195.       RETURN
  196. *
  197. * Format handling
  198. *
  199. *
  200. * Error handling
  201. *
  202.  9999 CONTINUE
  203.       IRET=1
  204.       WRITE(IOIMP,*) 'An error was detected in subroutine relr1b'
  205.       RETURN
  206. *
  207. * End of subroutine RELR1B
  208. *
  209.       END
  210.  
  211.  
  212.  

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