Télécharger repico.eso

Retour à la liste

Numérotation des lignes :

repico
  1. C REPICO SOURCE CB215821 20/11/25 13:39:01 10792
  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.  
  37. -INC PPARAM
  38. -INC CCOPTIO
  39. -INC SMLMOTS
  40. INTEGER JGN,JGM
  41. POINTEUR ICOGLO.MLMOTS
  42. POINTEUR GPINCS.MLMOTS
  43. POINTEUR MLPRID.MLMOTS
  44. -INC SMLENTI
  45. INTEGER JG
  46. POINTEUR ICPRIB.MLENTI
  47. POINTEUR ICDUAB.MLENTI
  48. POINTEUR ICPRIC.MLENTI
  49. POINTEUR ICDUAC.MLENTI
  50. POINTEUR ICPRID.MLENTI
  51. -INC SMCHPOI
  52. POINTEUR CHPOD.MCHPOI
  53. POINTEUR IMATB.IMATRI
  54. POINTEUR IMATC.IMATRI
  55. *
  56. INTEGER IMPR,IRET
  57. *
  58. INTEGER LNMOTS
  59. PARAMETER (LNMOTS=8)
  60. *
  61. INTEGER NBMB,NBMC,NBMD,NIPRID,NIUNIQ
  62. INTEGER IBMB,IBMC,IBMD,IIPRID,IINC
  63. *
  64. *
  65. * Executable statements
  66. *
  67. IF (IMPR.GT.1) WRITE(IOIMP,*) 'Entrée dans repico.eso'
  68. * Enumération de tous les noms d'inconnues
  69. * Extraction éventuelles des composantes du chpoint
  70. * avec modif. pour qu'ils fassent 8 lettres
  71. IF (CHPOD.NE.0) THEN
  72. CALL ECRCHA('COMP')
  73. CALL ECROBJ('CHPOINT ',CHPOD)
  74. CALL EXTRAI
  75. CALL LIROBJ('LISTMOTS',MLPRID,1,IRET)
  76. IF (IRET.EQ.0) THEN
  77. WRITE(IOIMP,*) 'erreur extraction des composantes chpod'
  78. GOTO 9999
  79. ENDIF
  80. SEGACT MLPRID*MOD
  81. NIPRID=MLPRID.MOTS(/2)
  82. JGN=LNMOTS
  83. JGM=NIPRID
  84. SEGADJ,MLPRID
  85. DO 1 IIPRID=1,NIPRID
  86. MLPRID.MOTS(IIPRID)=
  87. $ MLPRID.MOTS(IIPRID)(1:4)//' '
  88. 1 CONTINUE
  89. ELSE
  90. MLPRID=0
  91. ENDIF
  92. SEGACT IMATB
  93. SEGACT IMATC
  94. NBMB=IMATB.LISPRI(/2)
  95. NBMC=IMATC.LISPRI(/2)
  96. JGN=LNMOTS
  97. JGM=2*(NBMB+NBMC)
  98. IF (MLPRID.NE.0) THEN
  99. NBMD=MLPRID.MOTS(/2)
  100. JGM=JGM+NBMD
  101. ENDIF
  102. *
  103. SEGINI GPINCS
  104. IINC=0
  105. DO 2 IBMB=1,NBMB
  106. IINC=IINC+1
  107. GPINCS.MOTS(IINC)=IMATB.LISPRI(IBMB)
  108. 2 CONTINUE
  109. DO 3 IBMC=1,NBMC
  110. IINC=IINC+1
  111. GPINCS.MOTS(IINC)=IMATC.LISPRI(IBMC)
  112. 3 CONTINUE
  113. DO 4 IBMB=1,NBMB
  114. IINC=IINC+1
  115. GPINCS.MOTS(IINC)=IMATB.LISDUA(IBMB)
  116. 4 CONTINUE
  117. DO 5 IBMC=1,NBMC
  118. IINC=IINC+1
  119. GPINCS.MOTS(IINC)=IMATC.LISDUA(IBMC)
  120. 5 CONTINUE
  121. IF (MLPRID.NE.0) THEN
  122. DO 6 IBMD=1,NBMD
  123. IINC=IINC+1
  124. GPINCS.MOTS(IINC)=MLPRID.MOTS(IBMD)
  125. 6 CONTINUE
  126. ENDIF
  127. * Elimination des doublons dans les noms
  128. JGN=LNMOTS
  129. JGM=IINC
  130. SEGINI ICOGLO
  131. CALL CUNIQ(GPINCS.MOTS,LNMOTS,IINC,
  132. $ ICOGLO.MOTS,NIUNIQ,
  133. $ IMPR,IRET)
  134. IF (IRET.NE.0) GOTO 9999
  135. JGN=LNMOTS
  136. JGM=NIUNIQ
  137. SEGADJ,ICOGLO
  138. SEGSUP GPINCS
  139. * Noms des inconnues primales et duales de B et C exprimées
  140. * dans le repérage défini par ICOGLO : IC{PRI,DUA}{B,C}
  141. JG=NBMB
  142. SEGINI ICPRIB
  143. CALL CREPER(LNMOTS,NBMB,NIUNIQ,
  144. $ IMATB.LISPRI,ICOGLO.MOTS,
  145. $ ICPRIB.LECT,
  146. $ IMPR,IRET)
  147. IF (IRET.NE.0) GOTO 9999
  148. SEGDES ICPRIB
  149. JG=NBMB
  150. SEGINI ICDUAB
  151. CALL CREPER(LNMOTS,NBMB,NIUNIQ,
  152. $ IMATB.LISDUA,ICOGLO.MOTS,
  153. $ ICDUAB.LECT,
  154. $ IMPR,IRET)
  155. IF (IRET.NE.0) GOTO 9999
  156. SEGDES ICDUAB
  157. JG=NBMC
  158. SEGINI ICPRIC
  159. CALL CREPER(LNMOTS,NBMC,NIUNIQ,
  160. $ IMATC.LISPRI,ICOGLO.MOTS,
  161. $ ICPRIC.LECT,
  162. $ IMPR,IRET)
  163. IF (IRET.NE.0) GOTO 9999
  164. SEGDES ICPRIC
  165. JG=NBMC
  166. SEGINI ICDUAC
  167. CALL CREPER(LNMOTS,NBMC,NIUNIQ,
  168. $ IMATC.LISDUA,ICOGLO.MOTS,
  169. $ ICDUAC.LECT,
  170. $ IMPR,IRET)
  171. IF (IRET.NE.0) GOTO 9999
  172. SEGDES ICDUAC
  173. IF (MLPRID.NE.0) THEN
  174. JG=NBMD
  175. SEGINI ICPRID
  176. CALL CREPER(LNMOTS,NBMD,NIUNIQ,
  177. $ MLPRID.MOTS,ICOGLO.MOTS,
  178. $ ICPRID.LECT,
  179. $ IMPR,IRET)
  180. IF (IRET.NE.0) GOTO 9999
  181. SEGDES ICPRID
  182. SEGSUP MLPRID
  183. ELSE
  184. ICPRID=0
  185. ENDIF
  186. SEGDES ICOGLO
  187. SEGDES IMATC
  188. SEGDES IMATB
  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 repico'
  203. RETURN
  204. *
  205. * End of subroutine REPICO
  206. *
  207. END
  208.  
  209.  
  210.  
  211.  
  212.  
  213.  
  214.  
  215.  
  216.  
  217.  

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