Sources Esope | Cast3M

manuc3
C MANUC3    SOURCE    CB215821  24/04/12    21:16:36     11897          
      SUBROUTINE MANUC3(MLENT1,MLMOTS,IPOI,MONMOT,MLMOT3,MLMOT2,
     .                  LETYP,JER1,MLMOT4,ICHA)
*------------------------------------------------------------------
*
*                 CREATION D'UN MCHAML
*
*------------------------------------------------------------------
      IMPLICIT INTEGER(I-N)
-INC SMCHAML
-INC SMLMOTS
-INC SMLREEL
-INC SMLENTI
-INC SMMODEL
 
-INC PPARAM
-INC CCOPTIO
*
* PARAMETRES:   (E)=ENTREE   (S)=SORTIE   (+ = CONTENU DANS UN COMMUN)
* -----------
*
*     MLENT1  (E) POINTEURS SUR ZONES ELEMENTAIRES DE MAILLAGE
*     MLMOTS  (E) POINTEUR SUR UN LISTMOTS CONTENANT LES NOMS
*     MLMOT3  (E) POINTEUR SUR UN LISTMOTS CONTENANT LES TYPES
*     MLMOT2  (E) POINTEUR SUR UN LISTMOTS CONTENANT LES TYPES
*     MLMOT4  (E) POINTEUR SUR UN LISTMOTS CONTENANT LES NOMS
*                 DES CONSTITUANTS
*     IPOI    (E) POINTEUR SUR UN LISTENTI OU UN LISTREEL
*     MONMOT  (E) MOT DE 8 CARACTERES
*     LETYP   (E) TYPE DU MCHAML A CREER
*     JER1    (E) LONGUEUR DE LA CHAINE DE CARACTERES
*     ICHA    (S) POINTEUR SUR LE MCHAML RESULTAT
*
* LANGAGE:
* --------
*
*    ESOPE + FORTRAN77
*
************************************************************************
*
      SEGMENT MPTVAL
        INTEGER IPOS(NS)    ,NSOF(NS)
        INTEGER      IVAL(NCOSOU)
        CHARACTER*16 TYVAL(NCOSOU)
      ENDSEGMENT
*
      SEGMENT NOTYPE
        CHARACTER*16 TYPE(NBTYPE)
      ENDSEGMENT
*
*
      PARAMETER ( N3=6 )
      PARAMETER (NINF=3)
      CHARACTER*8 MONMOT
      CHARACTER*(NCONCH) CONM
      CHARACTER*4 CAR,CAR2
      CHARACTER*(*) LETYP
      DIMENSION INFOS(NINF)
      NCOUCH=0
*
*     RECHERCHE DES ZONES DE MAILLAGE ELEMENTAIRES
*
      SEGACT,MLENT1
      N1=MLENT1.LECT(/1)
      INFOS(1) = 0
      INFOS(2) = 0
      INFOS(3) = NIFOUR
*
*     INITIALISATION DU SEGMENT MCHELM
*
      L1=JER1
      SEGINI,MCHELM
      ICHA=MCHELM
      TITCHE=LETYP
      IFOCHE=IFOUR
*
      SEGACT,MLMOTS
      SEGACT,MLMOT3
      SEGACT,MLMOT2
      SEGACT,MLMOT4
      N2=MOTS(/2)
      IF(MONMOT.EQ.'REAL*8  ') THEN
      MLREEL=IPOI
      SEGACT,MLREEL
      ELSE
      MLENTI=IPOI
      SEGACT,MLENTI
      ENDIF
*
*     BOUCLE SUR LES ZONES ELEMENTAIRES DU MAILLAGE
*
      DO 20 I=1,N1
         IPMAIL   =  MLENT1.LECT(I)
         CONCHE(I)=  MLMOT4.MOTS(I)
         IMACHE(I)=  IPMAIL
         INFCHE(I,1) = 0
         INFCHE(I,2) = NCOUCH
         INFCHE(I,3) = NIFOUR
         INFCHE(I,4) = 0
         INFCHE(I,5) = 0
         INFCHE(I,6) = 1
         SEGINI,MCHAML
         ICHAML(I)=MCHAML
*
         DO 10 IN=1,N2
            NOMCHE(IN)=MOTS(IN)
            IF (MONMOT.EQ.'REAL*8  ') THEN
               TYPCHE(IN)=MONMOT(1:6)
               N1PTEL=1
               N1EL=1
               N2PTEL=0
               N2EL=0
            ELSE
               CAR =MLMOT3.MOTS(IN)
               CAR2=MLMOT2.MOTS(IN)
*
*              TRAITEMENT PARTICULIER POUR LE TYPE 'MCHAML'
*
               IF (CAR.EQ.'MCHA') THEN
                  IPT = LECT(IN)
                  CALL QUESUP(0,IPT,0,0,ISUP,IRET)
                  IF(IERR.NE.0)THEN
                     SEGSUP MCHAML
                     GOTO 99
                  ENDIF
                  IF (ISUP.NE.1)THEN
                    MCHEL1=IPT
                    SEGACT MCHEL1
                    MOTERR(1:8)=MCHEL1.TITCHE
                    CALL ERREUR(124)
                    SEGSUP MCHAML
                   GOTO 99
                  ENDIF
                  NBROBL=1
                  NBRFAC=0
                  SEGINI NOMID
                  MOTAUX=NOMID
                  LESOBL(1)=NOMCHE(IN)
                  NBTYPE=1
                  SEGINI NOTYPE
                  MOTYPE=NOTYPE
                  TYPE(1)=' '
                  CONM=CONCHE(I)
           CALL KOMCHA(IPT,IPMAIL,CONM,MOTAUX,MOTYPE,1,INFOS,3,IVAAUX)
                  SEGSUP NOTYPE
                  IF (IERR.NE.0)THEN
                     SEGSUP MCHAML
                     GOTO 99
                  ENDIF
                  MPTVAL=IVAAUX
                  TYPCHE(IN)=TYVAL(1)
                  MELVA1 = IVAL(1)
                  SEGINI,MELVAL=MELVA1
                  IELVAL(IN) = MELVAL
                  GO TO 10
               ENDIF
*
               TYPCHE(IN)='POINTEUR'//CAR(1:4)//CAR2(1:4)
               N1PTEL=0
               N1EL=0
               N2PTEL=1
               N2EL=1
            ENDIF
*
*           INITIALISATION DU SEGMENT MELVAL
*
            SEGINI,MELVAL
            IELVAL(IN)=MELVAL
            IF (MONMOT.EQ.'REAL*8  ') THEN
               VELCHE(N1PTEL,N1EL)=PROG(IN)
            ELSE
               IELCHE(N2PTEL,N2EL)=LECT(IN)
            ENDIF
 10         CONTINUE
*        END DO
 20      CONTINUE
*     END DO
*
 99   CONTINUE
*
      IF(IERR.NE.0) SEGSUP,MCHELM
*
      END