Télécharger la plaquette Cast3M


fr en

Télécharger guesco.eso

Retour à la liste

Numérotation des lignes : 

guesco

  1. C GUESCO    SOURCE    GOUNAND   25/09/11    21:15:01     12361          
  2.       SUBROUTINE GUESCO(TYCHA,MLMOTS,MLMOT1)
  3.       IMPLICIT REAL*8 (A-H,O-Z)
  4.       IMPLICIT INTEGER (I-N)
  5. C***********************************************************************
  6. C NOM         : GUESCO
  7. C DESCRIPTION : Devine des noms de composantes et leur nombre
  8. C               a partir de la donnée de MLMOTS (eventuellement
  9. C               incomplete si TYCHA=CHPOINT)
  10. C               Si on ne sait pas, on renvoie MLMOT1=0
  11. C
  12. C
  13. C LANGAGE     : ESOPE
  14. C AUTEUR      : Stephane GOUNAND (CEA/DES/ISAS/DM2S/SEMT/LTA)
  15. C               mel : gounand@semt2.smts.cea.fr
  16. C***********************************************************************
  17. C APPELES          :
  18. C APPELES (E/S)    :
  19. C APPELES (BLAS)   :
  20. C APPELES (CALCUL) :
  21. C APPELE PAR       :
  22. C***********************************************************************
  23. C SYNTAXE GIBIANE    :
  24. C ENTREES            : TYCHA, MLMOTS
  25. C ENTREES/SORTIES    :
  26. C SORTIES            : MLMOT1
  27. C***********************************************************************
  28. C VERSION    : v1, 10/09/2024, version initiale
  29. C HISTORIQUE : v1, 10/09/2024, creation
  30. C HISTORIQUE :
  31. C HISTORIQUE :
  32. C***********************************************************************
  33. -INC PPARAM
  34. -INC CCOPTIO
  35. -INC SMLMOTS
  36. *
  37.       CHARACTER*8 TYCHA
  38.       PARAMETER (NTCC=3)
  39. * On se limite à la dimension 3
  40.       CHARACTER*1 MOCC(3,NTCC)
  41.       character*8 NOMCO
  42.       character*8 PRECO
  43.       character*1 CLET
  44.       EXTERNAL LONG
  45. C
  46.       DATA MOCC/'1','2','3','X','Y','Z','R','Z','T'/
  47. *
  48. * Executable statements
  49. *
  50.       MLMOT1=0
  51.       SEGACT,MLMOTS
  52.       NBMOTS=MOTS(/2)
  53. * Les cas simples
  54.       IF (NBMOTS.LE.0) THEN
  55. * Le chpoint donne est vide, ou bien son contenu est incompatible avec les noms
  56. * de composante imposes par le listmots et le mot-cle (donne ou sous-entendu)
  57.          CALL ERREUR(156)
  58.          RETURN
  59.       ENDIF
  60. * On essaie de deviner a partir du nom de la premiere composante
  61.       NOMCO=MOTS(1)
  62. * Est-ce un vecteur ou un tenseur ?
  63.       NBCC=0
  64.       LNOMCO=LONG(NOMCO)
  65. *      write(ioimp,*) 'lnomco=',lnomco
  66.       IF (LNOMCO.GE.1) THEN
  67.          CLET=NOMCO(LNOMCO:LNOMCO)
  68.          JTCC=0
  69.          DO ITCC=1,NTCC
  70.             DO JDIM=1,IDIM
  71.                IF (CLET.EQ.MOCC(JDIM,ITCC)) THEN
  72.                   JTCC=ITCC
  73.                   NBCC=NBCC+1
  74.                   GOTO 5
  75.                ENDIF
  76.             ENDDO
  77.          ENDDO
  78.  5       CONTINUE
  79.          IF (NBCC.NE.0) THEN
  80.             IF (LNOMCO.GT.2) THEN
  81.                CLET=NOMCO(LNOMCO-1:LNOMCO-1)
  82.                DO JDIM=1,IDIM
  83.                   IF (CLET.EQ.MOCC(JDIM,JTCC)) THEN
  84.                      NBCC=NBCC+1
  85.                      GOTO 6
  86.                   ENDIF
  87.                ENDDO
  88.  6             CONTINUE
  89.             ENDIF
  90.          ENDIF
  91.       ENDIF
  92. *     NBCC =2 tenseur potentiel mais il reste à voir symetrique ou non ;
  93. *     NBCC =1 vecteur potentiel ; NBCC=0 scalaire potentiel
  94. *      write(ioimp,*) 'NBCC=',NBCC
  95.       PRECO=NOMCO(1:(LNOMCO-NBCC))
  96.       IF (TYCHA.EQ.'CHPOINT') THEN
  97.          JGN=LOCHPO
  98.       ELSE
  99.          JGN=LOCOMP
  100.       ENDIF
  101.       IF (NBCC.EQ.2) THEN
  102.          ISYM=3
  103.       ELSE
  104.          ISYM=1
  105.       ENDIF
  106.       DO 1000 JSYM=1,ISYM
  107. *         write(ioimp,*) 'JSYM=',JSYM
  108.          IF (NBCC.EQ.0) THEN
  109.             JGM=1
  110.             IF (TYCHA.EQ.'CHPOINT') THEN
  111.                IF (NBMOTS.GT.JGM) GOTO 99
  112.             ELSE
  113.                IF (NBMOTS.NE.JGM) GOTO 99
  114.             ENDIF
  115.             SEGINI MLMOT1
  116.             MLMOT1.MOTS=PRECO
  117.          ELSEIF (NBCC.EQ.1) THEN
  118.             JGM=IDIM
  119.             IF (TYCHA.EQ.'CHPOINT') THEN
  120.                IF (NBMOTS.GT.JGM) GOTO 99
  121.             ELSE
  122.                IF (NBMOTS.NE.JGM) GOTO 99
  123.             ENDIF
  124.             PRECO=NOMCO(1:(LNOMCO-1))
  125.             JGM=IDIM
  126.             SEGINI MLMOT1
  127.             DO JDIM=1,IDIM
  128.                PRECO(LNOMCO:LNOMCO)=MOCC(JDIM,JTCC)
  129.                MLMOT1.MOTS(JDIM)=PRECO
  130.             ENDDO
  131.          ELSEIF (NBCC.EQ.2) THEN
  132.             IF (JSYM.EQ.1.OR.JSYM.EQ.2) THEN
  133.                JGM=IDIM*(IDIM+1)/2
  134.             ELSE
  135.                JGM=IDIM*IDIM
  136.             ENDIF
  137.             IF (TYCHA.EQ.'CHPOINT') THEN
  138.                IF (NBMOTS.GT.JGM) THEN
  139.                   IF (JSYM.LT.ISYM) THEN
  140.                      GOTO 1000
  141.                   ELSE
  142.                      GOTO 99
  143.                   ENDIF
  144.                ENDIF
  145.             ELSE
  146.                IF (NBMOTS.NE.JGM) THEN
  147.                   IF (JSYM.LT.ISYM) THEN
  148.                      GOTO 1000
  149.                   ELSE
  150.                      GOTO 99
  151.                   ENDIF
  152.                ENDIF
  153.             ENDIF
  154.             IGM=0
  155.             SEGINI MLMOT1
  156.             DO JDIM=1,IDIM
  157.                IF (JSYM.EQ.1.OR.JSYM.EQ.2) THEN
  158.                   LDIM=JDIM
  159.                ELSEIF (JSYM.EQ.3) THEN
  160.                   LDIM=IDIM
  161.                else
  162.                   call erreur(5)
  163.                   return
  164.                ENDIF
  165.                DO KDIM=1,LDIM
  166.                   IF (JSYM.NE.2) THEN
  167.                      PRECO(LNOMCO-1:LNOMCO-1)=MOCC(JDIM,JTCC)
  168.                      PRECO(LNOMCO:LNOMCO)=MOCC(KDIM,JTCC)
  169.                   ELSE
  170.                      PRECO(LNOMCO-1:LNOMCO-1)=MOCC(KDIM,JTCC)
  171.                      PRECO(LNOMCO:LNOMCO)=MOCC(JDIM,JTCC)
  172.                   ENDIF
  173.                   IGM=IGM+1
  174.                   MLMOT1.MOTS(IGM)=PRECO
  175.                ENDDO
  176.             ENDDO
  177.          ELSE
  178. *            write(ioimp,*) 'NBCC=',NBCC,' ?'
  179.             MOTERR(1:8)='GUESCO'
  180.             CALL ERREUR(1039)
  181.             RETURN
  182.          ENDIF
  183. *         write(ioimp,*) 'GUESCO : MLMOTS=',(MOTS(i2),i2=1,MOTS(/2))
  184. *         write(ioimp,*) 'GUESCO : MLMOT1=',(MLMOT1.MOTS(i2),i2=1
  185. *     $        ,MLMOT1.MOTS(/2))
  186. * Verifions la présence de toutes les composantes dans la liste devinee
  187.          ICMP=0
  188.          DO I=1,MOTS(/2)
  189.             CALL PLACE (MLMOT1.MOTS,MLMOT1.MOTS(/2),IPLAC,MOTS(I))
  190.             IF (IPLAC.NE.0) ICMP=ICMP+1
  191.          ENDDO
  192. *         write(ioimp,*) 'ICMP=',ICMP
  193.          IF (ICMP.NE.MOTS(/2)) THEN
  194. * Deuxième chance pour le tenseur
  195.             IF (NBCC.EQ.2.AND.JSYM.NE.ISYM) GOTO 1000
  196.             GOTO 99
  197.          ELSE
  198.             GOTO 1001
  199.          ENDIF
  200.  1000 CONTINUE
  201.  1001 CONTINUE
  202. * On a trouve une bonne liste de composante et MLMOT1 est ordonnee
  203. * suivant la convention CASTEM (G11 G21 G22)
  204.       SEGACT MLMOT1
  205. *
  206. * Normal termination
  207. *
  208.       RETURN
  209. *
  210. *     On n'a pas su trouver une bonne liste, MLMOT1=0
  211. *
  212.  99   CONTINUE
  213.       RETURN
  214. *
  215. * Format handling
  216. *
  217. *
  218. * Error handling
  219. *
  220.  9999 CONTINUE
  221.       WRITE(IOIMP,*) 'An error was detected in subroutine guesco'
  222.       RETURN
  223. *
  224. * End of subroutine GUESCO
  225. *
  226.       END
  227.  
  228.  

© Cast3M 2003 - Tous droits réservés.
Mentions légales