Sources Esope | Cast3M

manuch
C MANUCH    SOURCE    FANDEUR   22/01/03    21:15:28     11136          
      SUBROUTINE MANUCH
************************************************************************
* NOM         : MANUCH
* DESCRIPTION : Cree et initialise un objet de type CHPOINT
************************************************************************
* SYNTAXE (GIBIANE) :
*
*     CHPO1 = MANU  'CHPO' GEO1 | LMOT1  LREE1                 |
*                               |                              |
*                               |(ENTI1) MOT1 VAL1   MOT2 VAL2 |
*                               |        ---------   --------- |
*                               |            |___________|     |
*                               |              ENTI1 fois      |
*                          ('TITRE'  MOT3)
*                          ('NATURE' MOT4) ;
*
************************************************************************
      IMPLICIT INTEGER(I-N)
 
-INC PPARAM
-INC CCOPTIO
-INC SMCHPOI
-INC SMLMOTS
-INC SMLREEL
-INC SMELEME
-INC SMCOORD
*
      SEGMENT       ICPR(nbpts)
      SEGMENT       ICP1(NBP1),ICP2(NBP2)
      SEGMENT       IPLREE(JG)
*
      REAL*8        VFLOT
      CHARACTER*(LOCOMP) MOYY
      CHARACTER*72  TITRE
*
*     MOOPT CONTIENT LES MOTS-CLES DE L'OPERATEUR
      PARAMETER     (LMOOPT=2)
      CHARACTER*4   MOOPT(LMOOPT)
      DATA MOOPT    /'TITR','NATU'/
*
*     ADDI CONTIENT LES MOTS-CLES DU PREMIER ATTRIBUT (NATURE)
      CHARACTER*4   ADDI(3)
      DATA ADDI     /'INDE','DIFF','DISC'/
*
*     ATTRI CONTIENT LES VALEURS DES ATTRIBUTS (LIMITE A 10)
      INTEGER       ATTRI(10)
*
*     BOOLEEN INDIQUANT SI ON A DONNE UN MAILLAGE DE POI1
      LOGICAL KPOI1
*
*     BOOLEEN INDIQUANT QU'AU MOINS UNE COMPOSANTE EST VARIABLE
      LOGICAL KVARI
 
      KVARI = .FALSE.
*
*
*
*     +---------------------------------------------------------------+
*     |           L E C T U R E   D E S   M O T S - C L E S           |
*     +---------------------------------------------------------------+
*          (DANS LE CAS OU ILS SONT PLACES EN TETE D'INSTRUCTION)
*
      TITRE = ' '
      DO I=1,10
          ATTRI(I)=0
      ENDDO
*
 100  CALL LIRMOT(MOOPT,LMOOPT,IMOT,0)
      IF (IERR.NE.0) RETURN
*
*     MOT-CLE "TITR"
*     ==============
      IF (IMOT.EQ.1) THEN
          CALL LIRCHA(TITRE,1,IRETOU)
          IF (IERR.NE.0) RETURN
          GOTO 100
*
*     MOT-CLE "NATU"
*     ==============
      ELSEIF (IMOT.EQ.2) THEN
          CALL LIRMOT(ADDI,3,ATTRI(1),1)
          IF (IERR .NE. 0) RETURN
          ATTRI(1) = ATTRI(1) - 1
          GOTO 100
      ENDIF
*
*
*
*     +---------------------------------------------------------------+
*     |         L E C T U R E   D E   L A   G E O M E T R I E         |
*     +---------------------------------------------------------------+
*
*     GEOMETRIE SOUS FORME DE "POINT"
      CALL LIROBJ('POINT   ',KPOINT,0,IRETOU)
      IF (IRETOU.NE.0) THEN
          CALL CRELEM(KPOINT)
          MELEME = KPOINT
          SEGACT MELEME
          KPOI1 = .TRUE.
*
*     GEOMETRIE SOUS FORME DE "MAILLAGE"
      ELSE
          CALL LIROBJ('MAILLAGE',MELEME,1,IRETOU)
          IF (IERR.NE.0) RETURN
          SEGACT MELEME
          KPOI1 = (ITYPEL.EQ.1.AND.LISOUS(/1).EQ.0)
      ENDIF
*
*     NBP1 = Nombre de noeuds avec doublons eventuels
*     NBP2 = Nombre de noeuds sans aucun doublon
*
*     CREATION D'UN MAILLAGE DE POI1 SANS DOUBLONS
      IF (KPOI1) THEN
*
*         BOUCLE SUR LES NOEUDS DU MAILLAGE
*         => ON DETECTE LES DOUBLONS EVENTUELS EN REMPLISSANT ICPR
*         => ON CREE IPT1, LE MAILLAGE CORRESPONDANT A MELEME SANS LES DOUBLONS
*            (ON LE CREE MANUELLEMENT PLUTOT QUE D'APPELER "CHANGE"
*             AFIN DE MAITRISER LA NUMEROTATION DE NOEUDS DANS IPT1
*             ET ETRE SUR DE LA BONNE CORRESPONDANCE AVEC LE MLREEL)
*         => DANS ICP1, ON RELIE LE RANG DANS MELEME AU RANG DANS IPT1 :
*            ICP1(RANG_AVEC_DOUBLONS) = RANG_SANS_DOUBLONS
          NBP1 = NUM(/2)
          NBP2 = 0
*
          SEGINI ICPR,ICP1
*
          NBNN=1
          NBELEM=NBP1
          NBSOUS=0
          NBREF=0
          SEGINI IPT1
          IPT1.ITYPEL=1
*
          DO I=1,NBP1
              IKI = NUM(1,I)
              IF (ICPR(IKI).EQ.0) THEN
                  NBP2 = NBP2+1
                  ICPR(IKI) = NBP2
                  IPT1.NUM(1,NBP2) = IKI
              ENDIF
              ICP1(I) = ICPR(IKI)
          ENDDO
*
          SEGSUP ICPR
*bp : ajout du cas ou NBP2 = NBP1 : on conserve le bon MELEME
          if (NBP2.eq.NBP1) then
            SEGSUP,IPT1
          else
*           On peut desormais remplacer MELEME par IPT1
            NBELEM=NBP2
            SEGADJ IPT1
*bp : ajout de la verif que ce maillage n existe pas deja via crech1
            ipt11=ipt1
            call crech1(ipt1,1)
            MELEME = IPT1
            if (IPT1.ne.ipt11) then
              IPT1=ipt11
              segsup,IPT1
            endif
          endif
*
      ELSE
*
*         L'APPEL A "CHANGE" SUFFIT POUR ELIMINER TOUS LES DOUBLONS
          CALL CHANGE(MELEME,1)
          NBP1 = NUM(/2)
          NBP2 = NBP1
*
      ENDIF
*
*
*     +---------------------------------------------------------------+
*     |         L E C T U R E   D E S   C O M P O S A N T E S         |
*     +---------------------------------------------------------------+
*
*
*     SYNTAXE 1
*     =========
*
*     MANU 'CHPO' GEO1 LMOT1 LREE1 ;
*     => ATTRIBUE UNE VALEUR CONSTANTE A CHAQUE COMPOSANTE (NULLE SI
*        PLUS DE COMPOSANTES DANS LMOT1 QUE DE VALEURS DANS LREE1)
*
      CALL LIROBJ('LISTMOTS',MLMOTS,0,ISYNTA1)
      IF (ISYNTA1.NE.0) THEN
*
*         NC = Nombre de noms de composantes dans le LISTMOTS
*         NR = Nombre de valeurs reelles dans le LISTREEL
*
*
*         LECTURE DES NOMS
*         ****************
*
          SEGACT MLMOTS
          NC  = MOTS(/2)
          ILU = 1
 
*         LECTURE DES VALEURS
*         *******************
*
          CALL LIROBJ('LISTREEL',MLREEL,1,IRETOU)
          IF (IERR.NE.0) RETURN
          SEGACT MLREEL
          NR = PROG(/1)
          JG = NC
          SEGINI IPLREE
c           DO I=1,NC
c               IPLREE(I)=0
c           ENDDO
          IF (NR.LT.NC) THEN
              SEGADJ MLREEL
              DO I=NR+1,NC
                  PROG(I)=0.D0
              ENDDO
          ENDIF
*
*
*     SYNTAXE 2
*     =========
*
*     MANU 'CHPO' GEO1 (ENTI1) MOT1 VAL1 (MOT2 VAL2 ...) ;
*     => ATTRIBUE UNE VALEUR OU UNE LISTE DE VALEURS A CHAQUE COMPOSANTE
*        (LES VALi PEUVENT ETRE DE TYPE FLOTTANT OU LISTREEL)
*
      ELSE
*
*         ILU = 1 si le nombre de composantes est specifie (0 sinon)
*         NCC = Nombre de composantes indique par l'utilisateur
*         NC  = Nombre de composantes lues dans MOT1, MOT2, etc...
          CALL LIRENT(NCC,0,IRETOU)
          JGN=LOCOMP
          IF (IRETOU.NE.0) THEN
              ILU=1
              INTERR(1)= NCC
              IF (NCC.LE.0) CALL ERREUR(36)
              IF (IERR.NE.0) RETURN
              JGM=NCC
              JG =NCC
          ELSE
              ILU=0
              JGM=1
              JG=0
          ENDIF
          SEGINI MLMOTS,MLREEL,IPLREE
*
          NC = 0
*
  20      CONTINUE
*
*
*             LECTURE DU NOM
*             **************
*
              CALL LIRCHA(MOYY,0,IRETOU)
              IF (IRETOU.EQ.0) THEN
                  IF (ILU.EQ.1) THEN
                      CALL ERREUR(80)
                      RETURN
                  ELSE
                      GOTO 21
                  ENDIF
              ENDIF
              IF (IERR.NE.0) RETURN
*
              IF (IRETOU.GT.LOCOMP) THEN
                  CALL ERREUR(536)
                  RETURN
              ENDIF
*
*
*             LECTURE DES VALEURS CORRESPONDANTES...
*             **************************************
*
*             ...SOUS-FORME DE FLOTTANT ?
              CALL LIRREE(VFLOT,0,IFLO)
*
*             ...OU SOUS-FORME DE LISTREEL ?
              IF (IFLO.EQ.0) THEN
                  CALL LIROBJ('LISTREEL',MLREE1,1,ILIS)
                  IF (IERR.NE.0) RETURN
*
                  SEGACT MLREE1
                  N = MLREE1.PROG(/1)
*
                  IF (N.NE.NBP1.AND.N.NE.1) CALL ERREUR(726)
                  IF (IERR.NE.0) RETURN
*
*                 ...FINALEMENT NON, C'EST BIEN UN UNIQUE FLOTTANT !
                  IF (N.EQ.1) THEN
                     VFLOT = MLREE1.PROG(1)
                     IFLO = 1
                  ENDIF
              ENDIF
*
*
*             MEMORISATION DES NOMS DANS MLMOTS
*             MEMORISATION DES VALEURS DANS MLREEL OU IPLREE
*             **********************************************
*
              NC = NC + 1
*
              IF (ILU.EQ.0) THEN
                  JGM = NC
                  JG = NC
                  SEGADJ MLMOTS,MLREEL,IPLREE
              ENDIF
*
              MOTS(NC) = MOYY
*
              IF (IFLO.NE.0) THEN
                  IPLREE(NC) = 0
                  PROG(NC)   = VFLOT
              ELSE
                  KVARI = .TRUE.
                  IPLREE(NC) = MLREE1
              ENDIF
*
              IF (ILU.EQ.0.OR.NC.LT.NCC) GOTO 20
 21       CONTINUE
*
      ENDIF
*
*
*
*     +---------------------------------------------------------------+
*     |           L E C T U R E   D E S   M O T S - C L E S           |
*     +---------------------------------------------------------------+
*           (DANS LE CAS OU ILS SONT PLACES EN FIN D'INSTRUCTION)
*
 200  CONTINUE
      CALL LIRMOT(MOOPT,LMOOPT,IMOT,0)
      IF (IERR.NE.0) RETURN
*
*     MOT-CLE "TITR"
*     ==============
      IF (IMOT.EQ.1) THEN
          CALL LIRCHA(TITRE,1,IRETOU)
          IF (IERR.NE.0) RETURN
          GOTO 200
*
*     MOT-CLE "NATU"
*     ==============
      ELSEIF (IMOT.EQ.2) THEN
          CALL LIRMOT(ADDI,3,ATTRI(1),1)
          IF (IERR .NE. 0) RETURN
          ATTRI(1) = ATTRI(1) - 1
          GOTO 200
      ENDIF
*
*
*
*     +---------------------------------------------------------------+
*     |             C R E A T I O N   D U   C H P O I N T             |
*     +---------------------------------------------------------------+
*
*
      IF (.NOT.KPOI1.AND.KVARI) CALL ERREUR(1040)
      IF (IERR.NE.0) RETURN
*
      IF (NBP1.NE.NBP2.AND.ATTRI(1).EQ.0) CALL ERREUR(1041)
      IF (IERR.NE.0) RETURN
*
*
*     INITIALISATION DES SEGMENTS MSOUPO ET MPOVAL DU CHPOINT
*     =======================================================
*
      SEGINI MSOUPO
      IGEOC = MELEME
      N = NBP2
*
      SEGINI MPOVAL
      IPOVAL = MPOVAL
*
*
*     BOUCLE SUR LES COMPOSANTES A CREER
*     ==================================
*
      DO IC=1,NC
*
          NOHARM(IC) = NIFOUR
          NOCOMP(IC) = MOTS(IC)
*l
          IF (IPLREE(IC).EQ.0) THEN
*
*             -------------------
*             COMPOSANTE UNIFORME
*             -------------------
*
              VFLOT=PROG(IC)
*
*             Maillage initial sans noeuds multiples
              IF (NBP1.EQ.NBP2) THEN
                  DO K=1,NBP1
                      VPOCHA(K,IC) = VFLOT
                  ENDDO
*
*             Noeuds multiples + Nature DIFFUSE
              ELSEIF (ATTRI(1).EQ.1) THEN
                  DO K=1,NBP2
                      VPOCHA(K,IC) = VFLOT
                  ENDDO
*
*             Noeuds multiples + Nature DISCRETE
              ELSEIF (ATTRI(1).EQ.2) THEN
                  DO K=1,NBP1
                      K1=ICP1(K)
                      VPOCHA(K1,IC) = VPOCHA(K1,IC) + VFLOT
                  ENDDO
              ENDIF
*
          ELSE
*
*             -------------------
*             COMPOSANTE VARIABLE
*             -------------------
*
              MLREE1=IPLREE(IC)
              SEGACT MLREE1
*
*             Maillage initial sans noeuds multiples
              IF (NBP1.EQ.NBP2) THEN
                  DO K=1,NBP1
                      VPOCHA(K,IC) = MLREE1.PROG(K)
                  ENDDO
*
*             Noeuds multiples + Nature DIFFUSE
              ELSEIF (ATTRI(1).EQ.1) THEN
                  SEGINI ICP2
                  DO K=1,NBP1
                      K1=ICP1(K)
                      VFLOT=MLREE1.PROG(K)
                      IF (ICP2(K1).EQ.1.AND.VPOCHA(K1,IC).NE.VFLOT) THEN
                          MOTERR=MOTS(IC)
                          CALL ERREUR(1042)
                          RETURN
                      ENDIF
                      VPOCHA(K1,IC) = VPOCHA(K1,IC) + VFLOT
                      ICP2(K1)=1
                  ENDDO
                  SEGSUP ICP2
*
*             Noeuds multiples + Nature DISCRETE
              ELSEIF (ATTRI(1).EQ.2) THEN
                  DO K=1,NBP1
                      K1=ICP1(K)
                      VPOCHA(K1,IC) = VPOCHA(K1,IC) + MLREE1.PROG(K)
                  ENDDO
              ENDIF
*
          ENDIF
*
      ENDDO
*
*
*     Un peu de menage...
      IF (ISYNTA1.NE.1) THEN
          SEGSUP MLMOTS,MLREEL
      ENDIF
      SEGSUP IPLREE
      IF (KPOI1) SEGSUP ICP1
*
*
*     CREATION DU CHAPEAU
*     ===================
*
      NSOUPO = 1
      NAT = 1
      SEGINI MCHPOI
      MOCHDE = TITRE
      MTYPOI = '        '
      DO I=1,NAT
          JATTRI(I) = ATTRI(I)
      ENDDO
      IFOPOI = IFOUR
      IPCHP(1)= MSOUPO
*
*
*     ECRITURE DU CHPOINT
*     ===================
*
      CALL ACTOBJ('CHPOINT ',MCHPOI,1)
      CALL ECROBJ('CHPOINT ',MCHPOI)
 
      END