Télécharger repico.eso

Retour à la liste

Numérotation des lignes :

  1. C REPICO SOURCE PV 16/11/17 22:01:21 9180
  2. SUBROUTINE REPICO(IMATB,IMATC,CHPOD,
  3. $ ICOGLO,ICPRIB,ICDUAB,ICPRIC,ICDUAC,ICPRID,
  4. $ IMPR,IRET)
  5. IMPLICIT INTEGER(I-N)
  6. IMPLICIT REAL*8 (A-H,O-Z)
  7. C***********************************************************************
  8. C NOM : REPICO
  9. C DESCRIPTION : Repérage global des inconnues : ICOGLO (LISTMOTS)
  10. C Noms des inconnues primales et duales de B et C exprimées
  11. C dans ce repérage : IC{PRI,DUA}{B,C}
  12. C (Eventuellement, si CHPOD.NE.0) :
  13. C Noms des inconnues de CHPOD dans ce repérage
  14. C
  15. C LANGAGE : ESOPE
  16. C AUTEUR : Stéphane GOUNAND (CEA/DRN/DMT/SEMT/LTMF)
  17. C mél : gounand@semt2.smts.cea.fr
  18. C***********************************************************************
  19. C APPELES : CUNIQ, CREPER
  20. C APPELES (E/S) : ECRCHA, ECROBJ
  21. C APPELE PAR : PROMAT
  22. C***********************************************************************
  23. C ENTREES : IMATB, IMATC, CHPOD
  24. C SORTIES : ICOGLO, ICPRIB, ICDUAB, ICPRIC, ICDUAC, ICPRID
  25. C CODE RETOUR (IRET) : = 0 si tout s'est bien passé
  26. C***********************************************************************
  27. C VERSION : v1, 28/01/2000, version initiale
  28. C HISTORIQUE : v1, 28/01/2000, création
  29. C HISTORIQUE :
  30. C HISTORIQUE :
  31. C***********************************************************************
  32. C Prière de PRENDRE LE TEMPS de compléter les commentaires
  33. C en cas de modification de ce sous-programme afin de faciliter
  34. C la maintenance !
  35. C***********************************************************************
  36. -INC CCOPTIO
  37. -INC SMLMOTS
  38. INTEGER JGN,JGM
  39. POINTEUR ICOGLO.MLMOTS
  40. POINTEUR GPINCS.MLMOTS
  41. POINTEUR MLPRID.MLMOTS
  42. -INC SMLENTI
  43. INTEGER JG
  44. POINTEUR ICPRIB.MLENTI
  45. POINTEUR ICDUAB.MLENTI
  46. POINTEUR ICPRIC.MLENTI
  47. POINTEUR ICDUAC.MLENTI
  48. POINTEUR ICPRID.MLENTI
  49. -INC SMCHPOI
  50. POINTEUR CHPOD.MCHPOI
  51. POINTEUR IMATB.IMATRI
  52. POINTEUR IMATC.IMATRI
  53. *
  54. INTEGER IMPR,IRET
  55. *
  56. INTEGER LNMOTS
  57. PARAMETER (LNMOTS=8)
  58. *
  59. INTEGER NBMB,NBMC,NBMD,NIPRID,NIUNIQ
  60. INTEGER IBMB,IBMC,IBMD,IIPRID,IINC
  61. *
  62. *
  63. * Executable statements
  64. *
  65. IF (IMPR.GT.1) WRITE(IOIMP,*) 'Entrée dans repico.eso'
  66. * Enumération de tous les noms d'inconnues
  67. * Extraction éventuelles des composantes du chpoint
  68. * avec modif. pour qu'ils fassent 8 lettres
  69. IF (CHPOD.NE.0) THEN
  70. CALL ECRCHA('COMP')
  71. CALL ECROBJ('CHPOINT ',CHPOD)
  72. CALL EXTRAI
  73. CALL LIROBJ('LISTMOTS',MLPRID,1,IRET)
  74. IF (IRET.EQ.0) THEN
  75. WRITE(IOIMP,*) 'erreur extraction des composantes chpod'
  76. GOTO 9999
  77. ENDIF
  78. SEGACT MLPRID*MOD
  79. NIPRID=MLPRID.MOTS(/2)
  80. JGN=LNMOTS
  81. JGM=NIPRID
  82. SEGADJ,MLPRID
  83. DO 1 IIPRID=1,NIPRID
  84. MLPRID.MOTS(IIPRID)=
  85. $ MLPRID.MOTS(IIPRID)(1:4)//' '
  86. 1 CONTINUE
  87. ELSE
  88. MLPRID=0
  89. ENDIF
  90. SEGACT IMATB
  91. SEGACT IMATC
  92. NBMB=IMATB.LISPRI(/2)
  93. NBMC=IMATC.LISPRI(/2)
  94. JGN=LNMOTS
  95. JGM=2*(NBMB+NBMC)
  96. IF (MLPRID.NE.0) THEN
  97. NBMD=MLPRID.MOTS(/2)
  98. JGM=JGM+NBMD
  99. ENDIF
  100. *
  101. SEGINI GPINCS
  102. IINC=0
  103. DO 2 IBMB=1,NBMB
  104. IINC=IINC+1
  105. GPINCS.MOTS(IINC)=IMATB.LISPRI(IBMB)
  106. 2 CONTINUE
  107. DO 3 IBMC=1,NBMC
  108. IINC=IINC+1
  109. GPINCS.MOTS(IINC)=IMATC.LISPRI(IBMC)
  110. 3 CONTINUE
  111. DO 4 IBMB=1,NBMB
  112. IINC=IINC+1
  113. GPINCS.MOTS(IINC)=IMATB.LISDUA(IBMB)
  114. 4 CONTINUE
  115. DO 5 IBMC=1,NBMC
  116. IINC=IINC+1
  117. GPINCS.MOTS(IINC)=IMATC.LISDUA(IBMC)
  118. 5 CONTINUE
  119. IF (MLPRID.NE.0) THEN
  120. DO 6 IBMD=1,NBMD
  121. IINC=IINC+1
  122. GPINCS.MOTS(IINC)=MLPRID.MOTS(IBMD)
  123. 6 CONTINUE
  124. ENDIF
  125. * Elimination des doublons dans les noms
  126. JGN=LNMOTS
  127. JGM=IINC
  128. SEGINI ICOGLO
  129. CALL CUNIQ(GPINCS.MOTS,LNMOTS,IINC,
  130. $ ICOGLO.MOTS,NIUNIQ,
  131. $ IMPR,IRET)
  132. IF (IRET.NE.0) GOTO 9999
  133. JGN=LNMOTS
  134. JGM=NIUNIQ
  135. SEGADJ,ICOGLO
  136. SEGSUP GPINCS
  137. * Noms des inconnues primales et duales de B et C exprimées
  138. * dans le repérage défini par ICOGLO : IC{PRI,DUA}{B,C}
  139. JG=NBMB
  140. SEGINI ICPRIB
  141. CALL CREPER(LNMOTS,NBMB,NIUNIQ,
  142. $ IMATB.LISPRI,ICOGLO.MOTS,
  143. $ ICPRIB.LECT,
  144. $ IMPR,IRET)
  145. IF (IRET.NE.0) GOTO 9999
  146. SEGDES ICPRIB
  147. JG=NBMB
  148. SEGINI ICDUAB
  149. CALL CREPER(LNMOTS,NBMB,NIUNIQ,
  150. $ IMATB.LISDUA,ICOGLO.MOTS,
  151. $ ICDUAB.LECT,
  152. $ IMPR,IRET)
  153. IF (IRET.NE.0) GOTO 9999
  154. SEGDES ICDUAB
  155. JG=NBMC
  156. SEGINI ICPRIC
  157. CALL CREPER(LNMOTS,NBMC,NIUNIQ,
  158. $ IMATC.LISPRI,ICOGLO.MOTS,
  159. $ ICPRIC.LECT,
  160. $ IMPR,IRET)
  161. IF (IRET.NE.0) GOTO 9999
  162. SEGDES ICPRIC
  163. JG=NBMC
  164. SEGINI ICDUAC
  165. CALL CREPER(LNMOTS,NBMC,NIUNIQ,
  166. $ IMATC.LISDUA,ICOGLO.MOTS,
  167. $ ICDUAC.LECT,
  168. $ IMPR,IRET)
  169. IF (IRET.NE.0) GOTO 9999
  170. SEGDES ICDUAC
  171. IF (MLPRID.NE.0) THEN
  172. JG=NBMD
  173. SEGINI ICPRID
  174. CALL CREPER(LNMOTS,NBMD,NIUNIQ,
  175. $ MLPRID.MOTS,ICOGLO.MOTS,
  176. $ ICPRID.LECT,
  177. $ IMPR,IRET)
  178. IF (IRET.NE.0) GOTO 9999
  179. SEGDES ICPRID
  180. SEGSUP MLPRID
  181. ELSE
  182. ICPRID=0
  183. ENDIF
  184. SEGDES ICOGLO
  185. SEGDES IMATC
  186. SEGDES IMATB
  187. *
  188. * Normal termination
  189. *
  190. IRET=0
  191. RETURN
  192. *
  193. * Format handling
  194. *
  195. *
  196. * Error handling
  197. *
  198. 9999 CONTINUE
  199. IRET=1
  200. WRITE(IOIMP,*) 'An error was detected in subroutine repico'
  201. RETURN
  202. *
  203. * End of subroutine REPICO
  204. *
  205. END
  206.  
  207.  
  208.  
  209.  
  210.  
  211.  
  212.  
  213.  

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