Sources Esope | Cast3M

guesco
C GUESCO    SOURCE    GOUNAND   25/10/23    21:15:02     12386          
      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     Si on a trouve une bonne liste de composante MLMOT1, elle est
C     ordonnee suivant la convention suivante :
C     Symetrique    : X11, X21, X22, X31, X32, X33
C     General       : X11, X12, X13, X21, X22, X23, X31, X32, X33
C
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 (JSYM.LT.ISYM) THEN
                     GOTO 1000
                  ELSE
                     GOTO 99
                  ENDIF
               ENDIF
            ELSE
               IF (NBMOTS.NE.JGM) THEN
                  IF (JSYM.LT.ISYM) THEN
                     GOTO 1000
                  ELSE
                     GOTO 99
                  ENDIF
               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.EQ.1.OR.JSYM.EQ.3) THEN
                     PRECO(LNOMCO-1:LNOMCO-1)=MOCC(JDIM,JTCC)
                     PRECO(LNOMCO:LNOMCO)=MOCC(KDIM,JTCC)
                  ELSEIF (JSYM.EQ.2) THEN
                     PRECO(LNOMCO-1:LNOMCO-1)=MOCC(KDIM,JTCC)
                     PRECO(LNOMCO:LNOMCO)=MOCC(JDIM,JTCC)
                  ELSE
                     call erreur(5)
                     return
                  ENDIF
                  IGM=IGM+1
*                  write(ioimp,*) 'JDIM,KDIM,PRECO=',JDIM,KDIM,PRECO
                  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
            SEGSUP MLMOT1
            MLMOT1=0
* 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
 
 
 
      SEGACT MLMOT1
*
* Normal termination
*
      RETURN
*
*     On n'a pas su trouver une bonne liste, MLMOT1=0
*
 99   CONTINUE
      MLMOT1=0
      RETURN
*
* Format handling
*
*
* Error handling
*
 9999 CONTINUE
      WRITE(IOIMP,*) 'An error was detected in subroutine guesco'
      RETURN
*
* End of subroutine GUESCO
*
      END