Sources Esope | Cast3M

prmcp4
C PRMCP4    SOURCE    CHAT      05/01/13    02:28:45     5004
      SUBROUTINE PRMCP4(ICMPRI,ICCPRI,NIUNIQ,
     $     ICOPRI,
     $     IMPR,IRET)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
C***********************************************************************
C NOM         : PRMCP4
C DESCRIPTION : Construction de la liste des inconnues communes à la
C               matrice et au chpoint.
C
* Construction de ICOPRI (LISTENTI), liste des inconnues
* appartenant à la fois à ICMPRI et ICCPRI
C
C
C LANGAGE     : ESOPE
C AUTEUR      : Stéphane GOUNAND (CEA/DRN/DMT/SEMT/LTMF)
C               mél : gounand@semt2.smts.cea.fr
C***********************************************************************
C APPELES          : -
C APPELE PAR       : PRMCP2
C***********************************************************************
C ENTREES            : ICMPRI, ICCPRI, NIUNIQ
C ENTREES/SORTIES    : -
C SORTIES            : ICOPRI
C CODE RETOUR (IRET) : = 0 si tout s'est bien passé
C***********************************************************************
C VERSION    : v1, 18/04/2000, version initiale
C HISTORIQUE : v1, 18/04/2000, création
C HISTORIQUE :
C HISTORIQUE :
C***********************************************************************
C Prière de PRENDRE LE TEMPS de compléter les commentaires
C en cas de modification de ce sous-programme afin de faciliter
C la maintenance !
C***********************************************************************
 
-INC PPARAM
-INC CCOPTIO
C
C**** Variables de COOPTIO
C
C      INTEGER IPLLB, IERPER, IERMAX, IERR, INTERR
C     &        ,IOTER,   IOLEC,  IOIMP,     IOCAR,  IOACQ
C     &        ,IOPER,   IOSGB,  IOGRA,     IOSAU,  IORES
C     &        ,IECHO,   IIMPI,  IOSPI
C     &        ,IDIM
C     &        ,MCOORD
C     &        ,IFOMOD, NIFOUR, IFOUR, NSDPGE, IONIVE
C     &        ,NGMAXY, IZROSF, ISOTYP, IOSCR,LTEXLU
C     &        ,NORINC,NORVAL,NORIND,NORVAD
C     &        ,NUCROU, IPSAUV
C
-INC SMLENTI
      INTEGER JG
      POINTEUR ICMPRI.MLENTI
      POINTEUR ICCPRI.MLENTI
      POINTEUR ICOPRI.MLENTI
      POINTEUR MLEWRK.MLENTI
      POINTEUR KRPRI.MLENTI
      POINTEUR MLQUNF.MLENTI
* Liste de MLENTI
      INTEGER NBMLEN
      SEGMENT MLENTS
      POINTEUR LISMLE(NBMLEN).MLENTI
      ENDSEGMENT
      POINTEUR GPMLES.MLENTS
*
      INTEGER IMPR,IRET
*
      INTEGER IBMLEN,IGWRK,IIUNIQ
      INTEGER        NGWRK,NIUNIQ
      INTEGER NUPRI,NBPRI
*
* Executable statements
*
      IF (IMPR.GT.2) WRITE(IOIMP,*) 'Entrée dans prmcp4.eso'
* Initialisation de la liste de MLENTI (ici, il y en a deux)
      NBMLEN=2
      SEGINI GPMLES
      GPMLES.LISMLE(1)=ICMPRI
      GPMLES.LISMLE(2)=ICCPRI
* NIUNIQ est la dimension de l'espace des noms d'inconnues
      JG=NIUNIQ
      SEGINI KRPRI
      SEGINI MLQUNF
      DO 2 IBMLEN=1,NBMLEN
         MLEWRK=GPMLES.LISMLE(IBMLEN)
         SEGACT MLEWRK
         NGWRK=MLEWRK.LECT(/1)
*
******** En general, ICMPRI peux contenir le meme nom
*        d'inconnue plusieurs fois.
*        Mais on doit conter sa contribution que une seule
*        fois!
*        C'est pur ça qu'on utilize le segment MEQUNF.LECT
*
         DO 22 IGWRK=1,NGWRK
            NUPRI=MLEWRK.LECT(IGWRK)
            IF(MLQUNF.LECT(NUPRI) .EQ. 0)THEN
               MLQUNF.LECT(NUPRI) = 1
               KRPRI.LECT(NUPRI)=KRPRI.LECT(NUPRI)+1
            ENDIF
 22      CONTINUE
         SEGDES MLEWRK
         DO IIUNIQ=1,NIUNIQ,1
            MLQUNF.LECT(IIUNIQ) = 0
         ENDDO
 2    CONTINUE
      SEGSUP GPMLES
      JG=0
      SEGINI ICOPRI
      DO 3 IIUNIQ=1,NIUNIQ
         NBPRI=KRPRI.LECT(IIUNIQ)
         IF (NBPRI.EQ.NBMLEN) THEN
            ICOPRI.LECT(**)=IIUNIQ
         ENDIF
 3    CONTINUE
      SEGDES ICOPRI
      SEGSUP KRPRI
      SEGSUP MLQUNF
*
* Normal termination
*
      IRET=0
      RETURN
*
* Format handling
*
*
* Error handling
*
 9999 CONTINUE
      IRET=1
      WRITE(IOIMP,*) 'An error was detected in subroutine prmcp4'
      RETURN
*
* End of subroutine PRMCP4
*
      END