Télécharger relr1b.eso

Retour à la liste

Numérotation des lignes :

  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. -INC CCOPTIO
  45. -INC SMRIGID
  46. POINTEUR DES.DESCR
  47. -INC SMELEME
  48. POINTEUR MEL.MELEME
  49. * Includes persos
  50. CBEGININCLUDE SMMINC
  51. SEGMENT MINC
  52. INTEGER NPOS(NPT+1)
  53. INTEGER MPOS(NPT,NBI+1)
  54. ENDSEGMENT
  55. SEGMENT IMINC
  56. INTEGER LNUPO (NDDL)
  57. INTEGER LNUINC(NDDL)
  58. ENDSEGMENT
  59. CENDINCLUDE SMMINC
  60. POINTEUR MINCP.MINC
  61. CBEGININCLUDE SMPMORS
  62. SEGMENT PMORS
  63. INTEGER IA (NTT+1)
  64. INTEGER JA (NJA)
  65. ENDSEGMENT
  66. CENDINCLUDE SMPMORS
  67. POINTEUR PMCOU.PMORS
  68. * Segment LSTIND (liste séquentielle indexée)
  69. SEGMENT LSTIND
  70. INTEGER IDX(NBM+1)
  71. INTEGER IELRIG(NBTVAL)
  72. INTEGER ILIGR (NBTVAL)
  73. ENDSEGMENT
  74. POINTEUR DDDNUL.LSTIND
  75. *
  76. -INC SMLENTI
  77. POINTEUR KRSPGP.MLENTI
  78. POINTEUR KRINCP.MLENTI
  79. POINTEUR IWORK.MLENTI
  80. POINTEUR DDDNOP.MLENTI
  81. *
  82. INTEGER IMPR,IRET
  83. *
  84. * Executable statements
  85. *
  86. IF (IMPR.GT.2) WRITE(IOIMP,*) 'Entrée dans relr1b.eso'
  87. NPOPRI=MINCP.NPOS(/1)-1
  88. NDDLPR=MINCP.NPOS(NPOPRI+1)-1
  89. SEGACT DDDNUL
  90. NDDLDU=DDDNUL.IDX(/1)-1
  91. *a effacer NEL=MEL.NUM(/2)
  92. NDDLOP=DES.NOELEP(/1)
  93. *a effacer NDDLOD=DES.NOELED(/1)
  94. * Segment de travail
  95. JG=NDDLPR
  96. SEGINI IWORK
  97. *
  98. * Passe 1 : construction de la correspondance :
  99. * ieme ddl dual <-> nombre des ddls
  100. * primaux avec lesquels
  101. * il est en relation
  102. * DDDNOP
  103. *
  104. JG=NDDLDU
  105. SEGINI DDDNOP
  106. DO IDDLDU=1,NDDLDU
  107. LDG=0
  108. * Fin de la liste chaînée
  109. LAST=-1
  110. DO JDX=DDDNUL.IDX(IDDLDU),
  111. $ DDDNUL.IDX(IDDLDU+1)-1
  112. IELEM =DDDNUL.IELRIG(JDX)
  113. * a effacer ILIGRD=DDDNUL.ILIGR(JDX)
  114. DO ILIGRP=1,NDDLOP
  115. IPO=KRSPGP.LECT(MEL.NUM(DES.NOELEP(ILIGRP),IELEM))
  116. IINC=KRINCP.LECT(ILIGRP)
  117. IPOS=MINCP.MPOS(IPO,IINC)
  118. IF (IPOS.EQ.0) THEN
  119. WRITE(IOIMP,*) 'Erreur grave no1'
  120. GOTO 9999
  121. ENDIF
  122. IDDLPR=MINCP.NPOS(IPO)+IPOS-1
  123. IF (IWORK.LECT(IDDLPR).EQ.0) THEN
  124. LDG=LDG+1
  125. IWORK.LECT(IDDLPR)=LAST
  126. LAST=IDDLPR
  127. ENDIF
  128. ENDDO
  129. ENDDO
  130. * Le nombre de points distincts trouvés est:
  131. DDDNOP.LECT(IDDLDU)=LDG
  132. * On remet la liste chaînée à 0
  133. DO ILDG=1,LDG
  134. IPREC=IWORK.LECT(LAST)
  135. IWORK.LECT(LAST)=0
  136. LAST=IPREC
  137. ENDDO
  138. ENDDO
  139. *
  140. * Passe 2 : construction de la correspondance :
  141. * ieme ddl dual de la matrice assemblée <->
  142. * (numéros des ddl primaux avec lesquels il est
  143. * en relation). C'est le profil morse (non ordonné)
  144. * PMCOU
  145. *
  146. *
  147. NTT=NDDLDU
  148. NJA=0
  149. SEGINI PMCOU
  150. IDEPA=1
  151. DO IDDLDU=1,NDDLDU
  152. PMCOU.IA(IDDLDU)=IDEPA
  153. IDEPA=IDEPA+DDDNOP.LECT(IDDLDU)
  154. ENDDO
  155. PMCOU.IA(NDDLDU+1)=IDEPA
  156. SEGSUP DDDNOP
  157. NJA=IDEPA-1
  158. SEGADJ PMCOU
  159. DO IDDLDU=1,NDDLDU
  160. KDX=PMCOU.IA(IDDLDU)-1
  161. DO JDX=DDDNUL.IDX(IDDLDU),
  162. $ DDDNUL.IDX(IDDLDU+1)-1
  163. IELEM =DDDNUL.IELRIG(JDX)
  164. * a effacer ILIGRD=DDDNUL.ILIGR(JDX)
  165. DO ILIGRP=1,NDDLOP
  166. IPO=KRSPGP.LECT(MEL.NUM(DES.NOELEP(ILIGRP),IELEM))
  167. IINC=KRINCP.LECT(ILIGRP)
  168. IPOS=MINCP.MPOS(IPO,IINC)
  169. IF (IPOS.EQ.0) THEN
  170. WRITE(IOIMP,*) 'Erreur grave no2'
  171. GOTO 9999
  172. ENDIF
  173. IDDLPR=MINCP.NPOS(IPO)+IPOS-1
  174. IF (IWORK.LECT(IDDLPR).EQ.0) THEN
  175. KDX=KDX+1
  176. PMCOU.JA(KDX)=IDDLPR
  177. IWORK.LECT(IDDLPR)=KDX
  178. ENDIF
  179. ENDDO
  180. ENDDO
  181. * On remet le segment de travail a zero
  182. DO KDX=PMCOU.IA(IDDLDU),PMCOU.IA(IDDLDU+1)-1
  183. IWORK.LECT(PMCOU.JA(KDX))=0
  184. ENDDO
  185. ENDDO
  186. SEGDES PMCOU
  187. SEGSUP IWORK
  188. SEGDES DDDNUL
  189. *
  190. * Normal termination
  191. *
  192. IRET=0
  193. RETURN
  194. *
  195. * Format handling
  196. *
  197. *
  198. * Error handling
  199. *
  200. 9999 CONTINUE
  201. IRET=1
  202. WRITE(IOIMP,*) 'An error was detected in subroutine relr1b'
  203. RETURN
  204. *
  205. * End of subroutine RELR1B
  206. *
  207. END
  208.  
  209.  
  210.  

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