Sources Esope | Cast3M

guesco
C GUESCO    SOURCE    GOUNAND   25/07/28    21:15:04     12338          
      SUBROUTINE GUESCO(TYCHA,MLMOTS,MLMOT1)
      IMPLICIT REAL*8 (A-H,O-Z)
      IMPLICIT INTEGER (I-N)
C***********************************************************************
C NOM         : GUESCO
C DESCRIPTION : Devine des noms de composantes et leur nombre
C               a partir de la donnée de MLMOTS (eventuellement
C               incomplete si TYCHA=CHPOINT)
C               Si on ne sait pas, on renvoie MLMOT1=0
C
C
C LANGAGE     : ESOPE
C AUTEUR      : Stephane GOUNAND (CEA/DES/ISAS/DM2S/SEMT/LTA)
C               mel : gounand@semt2.smts.cea.fr
C***********************************************************************
C APPELES          :
C APPELES (E/S)    :
C APPELES (BLAS)   :
C APPELES (CALCUL) :
C APPELE PAR       :
C***********************************************************************
C SYNTAXE GIBIANE    :
C ENTREES            : TYCHA, MLMOTS
C ENTREES/SORTIES    :
C SORTIES            : MLMOT1
C***********************************************************************
C VERSION    : v1, 10/09/2024, version initiale
C HISTORIQUE : v1, 10/09/2024, creation
C HISTORIQUE :
C HISTORIQUE :
C***********************************************************************
-INC PPARAM
-INC CCOPTIO
-INC SMLMOTS
*
      CHARACTER*8 TYCHA
      PARAMETER (NTCC=3)
* On se limite à la dimension 3
      CHARACTER*1 MOCC(3,NTCC)
      character*8 NOMCO
      character*8 PRECO
      character*1 CLET
      EXTERNAL LONG
C
      DATA MOCC/'1','2','3','X','Y','Z','R','Z','T'/
*
* Executable statements
*
      MLMOT1=0
      SEGACT,MLMOTS
      NBMOTS=MOTS(/2)
* Les cas simples
      IF (NBMOTS.LE.0) THEN
* Le chpoint donne est vide, ou bien son contenu est incompatible avec les noms
* de composante imposes par le listmots et le mot-cle (donne ou sous-entendu)
         CALL ERREUR(156)
         RETURN
      ENDIF
* On essaie de deviner a partir du nom de la premiere composante
      NOMCO=MOTS(1)
* Est-ce un vecteur ou un tenseur ?
      NBCC=0
      LNOMCO=LONG(NOMCO)
*      write(ioimp,*) 'lnomco=',lnomco
      IF (LNOMCO.GE.1) THEN
         CLET=NOMCO(LNOMCO:LNOMCO)
         JTCC=0
         DO ITCC=1,NTCC
            DO JDIM=1,IDIM
               IF (CLET.EQ.MOCC(JDIM,ITCC)) THEN
                  JTCC=ITCC
                  NBCC=NBCC+1
                  GOTO 5
               ENDIF
            ENDDO
         ENDDO
 5       CONTINUE
         IF (NBCC.NE.0) THEN
            IF (LNOMCO.GT.2) THEN
               CLET=NOMCO(LNOMCO-1:LNOMCO-1)
               DO JDIM=1,IDIM
                  IF (CLET.EQ.MOCC(JDIM,JTCC)) THEN
                     NBCC=NBCC+1
                     GOTO 6
                  ENDIF
               ENDDO
 6             CONTINUE
            ENDIF
         ENDIF
      ENDIF
*     NBCC =2 tenseur potentiel mais il reste à voir symetrique ou non ;
*     NBCC =1 vecteur potentiel ; NBCC=0 scalaire potentiel
*      write(ioimp,*) 'NBCC=',NBCC
      PRECO=NOMCO(1:(LNOMCO-NBCC))
      IF (TYCHA.EQ.'CHPOINT') THEN
         JGN=LOCHPO
      ELSE
         JGN=LOCOMP
      ENDIF
      IF (NBCC.EQ.2) THEN
         ISYM=3
      ELSE
         ISYM=1
      ENDIF
      DO 1000 JSYM=1,ISYM
*         write(ioimp,*) 'JSYM=',JSYM
         IF (NBCC.EQ.0) THEN
            JGM=1
            IF (TYCHA.EQ.'CHPOINT') THEN
               IF (NBMOTS.GT.JGM) GOTO 99
            ELSE
               IF (NBMOTS.NE.JGM) GOTO 99
            ENDIF
            SEGINI MLMOT1
            MLMOT1.MOTS=PRECO
         ELSEIF (NBCC.EQ.1) THEN
            JGM=IDIM
            IF (TYCHA.EQ.'CHPOINT') THEN
               IF (NBMOTS.GT.JGM) GOTO 99
            ELSE
               IF (NBMOTS.NE.JGM) GOTO 99
            ENDIF
            PRECO=NOMCO(1:(LNOMCO-1))
            JGM=IDIM
            SEGINI MLMOT1
            DO JDIM=1,IDIM
               PRECO(LNOMCO:LNOMCO)=MOCC(JDIM,JTCC)
               MLMOT1.MOTS(JDIM)=PRECO
            ENDDO
         ELSEIF (NBCC.EQ.2) THEN
            IF (JSYM.EQ.1.OR.JSYM.EQ.2) THEN
               JGM=IDIM*(IDIM+1)/2
            ELSE
               JGM=IDIM*IDIM
            ENDIF
            IF (TYCHA.EQ.'CHPOINT') THEN
               IF (NBMOTS.GT.JGM) THEN
                  IF (ISYM.EQ.1) GOTO 1000
                  GOTO 99
               ENDIF
            ELSE
               IF (NBMOTS.NE.JGM) THEN
                  IF (ISYM.EQ.1) GOTO 1000
                  GOTO 99
               ENDIF
            ENDIF
            IGM=0
            SEGINI MLMOT1
            DO JDIM=1,IDIM
               IF (JSYM.EQ.1.OR.JSYM.EQ.2) THEN
                  LDIM=JDIM
               ELSEIF (JSYM.EQ.3) THEN
                  LDIM=IDIM
               else
                  call erreur(5)
                  return
               ENDIF
               DO KDIM=1,LDIM
                  IF (JSYM.NE.2) THEN
                     PRECO(LNOMCO-1:LNOMCO-1)=MOCC(JDIM,JTCC)
                     PRECO(LNOMCO:LNOMCO)=MOCC(KDIM,JTCC)
                  ELSE
                     PRECO(LNOMCO-1:LNOMCO-1)=MOCC(KDIM,JTCC)
                     PRECO(LNOMCO:LNOMCO)=MOCC(JDIM,JTCC)
                  ENDIF
                  IGM=IGM+1
                  MLMOT1.MOTS(IGM)=PRECO
               ENDDO
            ENDDO
         ELSE
*            write(ioimp,*) 'NBCC=',NBCC,' ?'
            MOTERR(1:8)='GUESCO'
            CALL ERREUR(1039)
            RETURN
         ENDIF
*         write(ioimp,*) 'GUESCO : MLMOTS=',(MOTS(i2),i2=1,MOTS(/2))
*         write(ioimp,*) 'GUESCO : MLMOT1=',(MLMOT1.MOTS(i2),i2=1
*     $        ,MLMOT1.MOTS(/2))
* Verifions la présence de toutes les composantes dans la liste devinee
         ICMP=0
         DO I=1,MOTS(/2)
            CALL PLACE (MLMOT1.MOTS,MLMOT1.MOTS(/2),IPLAC,MOTS(I))
            IF (IPLAC.NE.0) ICMP=ICMP+1
         ENDDO
*         write(ioimp,*) 'ICMP=',ICMP
         IF (ICMP.NE.MOTS(/2)) THEN
* Deuxième chance pour le tenseur
            IF (NBCC.EQ.2.AND.JSYM.NE.ISYM) GOTO 1000
            GOTO 99
         ELSE
            GOTO 1001
         ENDIF
 1000 CONTINUE
 1001 CONTINUE
* On a trouve une bonne liste de composante et MLMOT1 est ordonnee
* suivant la convention CASTEM (G11 G21 G22)
      SEGACT MLMOT1
*
* Normal termination
*
      RETURN
*
*     On n'a pas su trouver une bonne liste, MLMOT1=0
*
 99   CONTINUE
      RETURN
*
* Format handling
*
*
* Error handling
*
 9999 CONTINUE
      WRITE(IOIMP,*) 'An error was detected in subroutine guesco'
      RETURN
*
* End of subroutine GUESCO
*
      END