Esope source files

   1 : C EXTIPD    SOURCE    MAGN      09/07/30    21:16:58     6458           
   2 :       SUBROUTINE EXTIPD
   3 :       IMPLICIT REAL*8 (A-H,O-Z)
   4 :       IMPLICIT INTEGER (I-N)
   5 : C***********************************************************************
   6 : C NOM         : EXTIPD
   7 : C DESCRIPTION : Extrait les noms d'inconnues primales ou duales
   8 : C               d'un MATRIK, on réduit à CH*4 pour des raisons
   9 : C               de compatibilité
  10 : C     
  11 : C     
  12 : C LANGAGE     : ESOPE
  13 : C AUTEUR      : Stéphane GOUNAND (CEA/DEN/DM2S/SFME/LTMF)
  14 : C               mél : gounand@semt2.smts.cea.fr
  15 : C***********************************************************************
  16 : C APPELES          :
  17 : C APPELES (E/S)    :
  18 : C APPELES (BLAS)   :
  19 : C APPELES (CALCUL) :
  20 : C APPELE PAR       :
  21 : C***********************************************************************
  22 : C SYNTAXE GIBIANE    :
  23 : C    LMOT1  = 'KOPS'  'EXTRINPR'  MATRIK1  ;
  24 : C    LMOT1  = 'KOPS'  'EXTRINDU'  MATRIK1  ;
  25 : C ENTREES            :
  26 : C ENTREES/SORTIES    :
  27 : C SORTIES            :
  28 : C CODE RETOUR (IRET) : = 0 si tout s'est bien passé
  29 : C***********************************************************************
  30 : C VERSION    : v1, 10/05/2006, version initiale
  31 : C HISTORIQUE : v1, 10/05/2006, création
  32 : C HISTORIQUE :
  33 : C HISTORIQUE :
  34 : C***********************************************************************
  35 : C Prière de PRENDRE LE TEMPS de compléter les commentaires
  36 : C en cas de modification de ce sous-programme afin de faciliter
  37 : C la maintenance !
  38 : C***********************************************************************
  39 : -INC CCOPTIO
  40 : -INC SMMATRIK
  41 : -INC SMLMOTS
  42 :       POINTEUR LINC.MLMOTS
  43 :       POINTEUR LINC2.MLMOTS
  44 : *     
  45 :       INTEGER IMPR,IRET
  46 : *     
  47 : * Executable statements
  48 : *     
  49 :       IMPR=0
  50 :       IF (IMPR.GT.2) WRITE(IOIMP,*) 'Entrée dans extipd.eso' 
  50 :       CALL LIROBJ('MATRIK  ',MATRIK,1,IRETOU)
  51 :       IF (IERR.NE.0) RETURN
  52 : * D'abord les primales puis les duales
  53 : * On renverse l'ordre car ecrobj écrit sur une pile
  54 :       DO IPRIDU=2,1,-1
  55 : *     
  56 : * Dim max de LINC
  57 : *     
  58 :          JGM=0
  59 :          SEGACT MATRIK
  60 :          NMAT=IRIGEL(/2)
  61 :          DO IMAT=1,NMAT
  62 :             IMATRI=IRIGEL(4,IMAT)
  63 :             SEGACT IMATRI
  64 :             JGM=JGM+LIZAFM(/2)
  65 :          ENDDO
  66 : *     
  67 : * Remplissage de LINC
  68 : *     
  69 :          JGN=4
  70 :          IGM=0
  71 :          SEGINI LINC
  72 :          DO IMAT=1,NMAT
  73 :             IMATRI=IRIGEL(4,IMAT)
  74 :             NBME=LIZAFM(/2)
  75 :             DO IBME=1,NBME
  76 :                IGM=IGM+1
  77 :                IF (IPRIDU.EQ.1) THEN
  78 :                   LINC.MOTS(IGM)=LISPRI(IBME)
  79 :                ELSEIF (IPRIDU.EQ.2) THEN
  80 :                   LINC.MOTS(IGM)=LISDUA(IBME)
  81 :                ELSE
  82 :                   GOTO 9999
  83 :                ENDIF
  84 :             ENDDO
  85 :             SEGDES IMATRI
  86 :          ENDDO
  87 :          SEGDES MATRIK
  88 : *     
  89 : * Enlever les doublons dans LINC
  90 : *     
  91 :          SEGINI,LINC2=LINC
  91 :          CALL CUNIQ(LINC2.MOTS,LINC2.MOTS(/1),LINC2.MOTS(/2),
  92 :      $        LINC.MOTS,NIUNIQ,
  93 :      $        IMPR,IRET)
  94 :          IF (IRET.NE.0) GOTO 9999
  95 :          JGN=4
  96 :          JGM=NIUNIQ
  97 :          SEGADJ,LINC
  98 :          SEGSUP LINC2
  99 :          SEGDES LINC
  99 :          CALL ECROBJ('LISTMOTS',LINC)
 100 :       ENDDO
 101 : *     
 102 : * Normal termination
 103 : *     
 104 : *      IRET=0
 105 :       RETURN
 106 : *     
 107 : * Format handling
 108 : *     
 109 : *     
 110 : * Error handling
 111 : *     
 112 :  9999 CONTINUE
 113 : *      IRET=1
 114 :       WRITE(IOIMP,*) 'An error was detected in subroutine extipd'
 114 :       CALL ERREUR(5)
 115 :       RETURN
 116 : *     
 117 : * End of subroutine EXTIPD
 118 : *     
 119 :       END
 120 : 
 121 :  
 122 :