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