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