Télécharger relr1d.eso

Retour à la liste

Numérotation des lignes :

  1. C RELR1D SOURCE GOUNAND 12/07/23 21:15:06 7441
  2. SUBROUTINE RELR1D(MINCP,KRSPGP,KRINCP,
  3. $ MINCD,KRSPGD,KRINCD,
  4. $ COEF,MEL,DES,XMAT,
  5. $ PROFM,
  6. $ VALM,
  7. $ IMPR,IRET)
  8. IMPLICIT REAL*8 (A-H,O-Z)
  9. IMPLICIT INTEGER (I-N)
  10. C***********************************************************************
  11. C NOM : RELR1D
  12. C DESCRIPTION :
  13. * Compléter les valeurs de la matrice morse avec celles
  14. * de XMAT
  15. C
  16. C
  17. C
  18. C LANGAGE : ESOPE
  19. C AUTEUR : Stéphane GOUNAND (CEA/DEN/DM2S/SFME/LTMF)
  20. C mél : gounand@semt2.smts.cea.fr
  21. C***********************************************************************
  22. C APPELES :
  23. C APPELES (E/S) :
  24. C APPELES (BLAS) :
  25. C APPELES (CALCUL) :
  26. C APPELE PAR : RELR14
  27. C***********************************************************************
  28. C SYNTAXE GIBIANE :
  29. C ENTREES :
  30. C ENTREES/SORTIES :
  31. C SORTIES :
  32. C CODE RETOUR (IRET) : = 0 si tout s'est bien passé
  33. C***********************************************************************
  34. C VERSION : v1, 01/07/2003, version initiale
  35. C HISTORIQUE : v1, 01/07/2003, création
  36. C HISTORIQUE :
  37. C HISTORIQUE :
  38. C***********************************************************************
  39. C Prière de PRENDRE LE TEMPS de compléter les commentaires
  40. C en cas de modification de ce sous-programme afin de faciliter
  41. C la maintenance !
  42. C***********************************************************************
  43. -INC CCOPTIO
  44. -INC SMRIGID
  45. POINTEUR DES.DESCR
  46. * POINTEUR IMAT.IMATRI
  47. POINTEUR XMAT.XMATRI
  48. -INC SMELEME
  49. POINTEUR MEL.MELEME
  50. * Includes persos
  51. CBEGININCLUDE SMMINC
  52. SEGMENT MINC
  53. INTEGER NPOS(NPT+1)
  54. INTEGER MPOS(NPT,NBI+1)
  55. ENDSEGMENT
  56. SEGMENT IMINC
  57. INTEGER LNUPO (NDDL)
  58. INTEGER LNUINC(NDDL)
  59. ENDSEGMENT
  60. CENDINCLUDE SMMINC
  61. POINTEUR MINCP.MINC
  62. POINTEUR MINCD.MINC
  63. CBEGININCLUDE SMPMORS
  64. SEGMENT PMORS
  65. INTEGER IA (NTT+1)
  66. INTEGER JA (NJA)
  67. ENDSEGMENT
  68. CENDINCLUDE SMPMORS
  69. POINTEUR PROFM.PMORS
  70. CBEGININCLUDE SMIZA
  71. SEGMENT IZA
  72. REAL*8 A(NBVA)
  73. ENDSEGMENT
  74. CENDINCLUDE SMIZA
  75. POINTEUR VALM.IZA
  76. *
  77. -INC SMLENTI
  78. POINTEUR KJSPGP.MLENTI
  79. POINTEUR KJSPGD.MLENTI
  80. POINTEUR KRSPGP.MLENTI
  81. POINTEUR KRSPGD.MLENTI
  82. POINTEUR KRINCP.MLENTI
  83. POINTEUR KRINCD.MLENTI
  84. *
  85. INTEGER IMPR,IRET
  86. *
  87. * Executable statements
  88. *
  89. IF (IMPR.GT.2) WRITE(IOIMP,*) 'Entrée dans relr1d.eso'
  90. NEL=MEL.NUM(/2)
  91. * NEL2=IMAT.IMATTT(/1)
  92. NEL2=XMAT.RE(/3)
  93. IF (NEL.NE.NEL2) THEN
  94. WRITE(IOIMP,*) 'Erreur grave no1'
  95. GOTO 9999
  96. ENDIF
  97. NLIGRP=DES.NOELEP(/1)
  98. NLIGRD=DES.NOELED(/1)
  99. DO IEL=1,NEL
  100. * XMAT=IMAT.IMATTT(IEL)
  101. * SEGACT XMAT
  102. DO ILIGRD=1,NLIGRD
  103. IPODU=KRSPGD.LECT(MEL.NUM(DES.NOELED(ILIGRD),IEL))
  104. IINCDU=KRINCD.LECT(ILIGRD)
  105. IPOSDU=MINCD.MPOS(IPODU,IINCDU)
  106. IF (IPOSDU.EQ.0) THEN
  107. WRITE(IOIMP,*) 'Erreur grave no1'
  108. GOTO 9999
  109. ENDIF
  110. IDDLDU=MINCD.NPOS(IPODU)+IPOSDU-1
  111. DO ILIGRP=1,NLIGRP
  112. IPOPR=KRSPGP.LECT(MEL.NUM(DES.NOELEP(ILIGRP),IEL))
  113. IINCPR=KRINCP.LECT(ILIGRP)
  114. IPOSPR=MINCP.MPOS(IPOPR,IINCPR)
  115. IF (IPOSPR.EQ.0) THEN
  116. WRITE(IOIMP,*) 'Erreur grave no2'
  117. GOTO 9999
  118. ENDIF
  119. IDDLPR=MINCP.NPOS(IPOPR)+IPOSPR-1
  120. IBVA=PROFM.IA(IDDLDU)
  121. LBVA=PROFM.IA(IDDLDU+1)-IBVA
  122. * A quel index du profil morse trouve-t-on le ddl IDDLPR ?
  123. CALL IFIDIC(LBVA,PROFM.JA(IBVA),IDDLPR,
  124. $ JBVA,
  125. $ IMPR,IRET)
  126. IF (IRET.NE.0) GOTO 9999
  127. VALM.A(IBVA+JBVA-1)=
  128. $ VALM.A(IBVA+JBVA-1)+
  129. $ (COEF*XMAT.RE(ILIGRD,ILIGRP,IEL))
  130. ENDDO
  131. ENDDO
  132. * WRITE(IOIMP,*) 'IEL=',IEL
  133. * CALL ECMORS(PROFM,VALM,3)
  134. * SEGDES XMAT
  135. ENDDO
  136. *
  137. * Normal termination
  138. *
  139. IRET=0
  140. RETURN
  141. *
  142. * Format handling
  143. *
  144. *
  145. * Error handling
  146. *
  147. 9999 CONTINUE
  148. IRET=1
  149. WRITE(IOIMP,*) 'An error was detected in subroutine relr1d'
  150. RETURN
  151. *
  152. * End of subroutine RELR1D
  153. *
  154. END
  155.  
  156.  
  157.  
  158.  

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