Télécharger la plaquette Cast3M


fr en

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

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