Sources Esope | Cast3M

trquaf
C TRQUAF    SOURCE    GOUNAND   24/11/06    21:15:18     12073          
      SUBROUTINE TRQUAF(CGEOME,CGEOMQ,MYFALS)
      IMPLICIT REAL*8 (A-H,O-Z)
      IMPLICIT INTEGER (I-N)
C***********************************************************************
C NOM         : TRQUAF
C PROJET      : Noyau linéaire NLIN
C DESCRIPTION : Transformation de CGEOME en QUAF si ça n'est pas le
C               cas. On utilise pour cela les éléments de référence
C               QUAI ou LINE
C               ATTENTION : les éléments QUAF créés ont des noeuds nuls
C               Vérifier que cela ne posera pas problème est fait dans
C               KECOM6 appelé par PRLIN3
C
C
C LANGAGE     : ESOPE
C AUTEUR      : Stéphane GOUNAND (CEA/DRN/DMT/SEMT/LTMF)
C               mél : gounand@semt2.smts.cea.fr
C***********************************************************************
C APPELES          : KEEF (recherche de l'élément fini)
C APPELE PAR       :
C***********************************************************************
C ENTREES            :
C SORTIES            :
C CODE RETOUR (IRET) : = 0 si tout s'est bien passé
C***********************************************************************
C VERSION    : v1, 27/05/2021, version initiale
C HISTORIQUE : v1, 27/05/2021, création
C HISTORIQUE :
C HISTORIQUE :
C***********************************************************************
C Prière de PRENDRE LE TEMPS de compléter les commentaires
C en cas de modification de ce sous-programme afin de faciliter
C la maintenance !
C***********************************************************************
 
-INC PPARAM
-INC CCOPTIO
-INC CCGEOME
-INC SMELEME
      POINTEUR CGEOMQ.MELEME
      POINTEUR CGEOME.MELEME
      POINTEUR SOUGEO.MELEME
-INC SMLMOTS
      POINTEUR MYLMOT.MLMOTS
* Mes includes persos
-INC TNLIN
*-INC SFALRF
      POINTEUR MYFALS.FALRFS
*-INC SELREF
      POINTEUR MYLRF.ELREF
*
      CHARACTER*4 MYDISC
      INTEGER IMPR,IRET
*
* Fonctions appelées
*
*
      INTEGER ICOMP ,ISOUS
      INTEGER        NSOUS,NDDL,ITQUAF
*
* Executable statements
*
      SEGACT CGEOME
      NBNN=0
      NBELEM=1
      NBSOUS=CGEOME.LISOUS(/1)
      NBREF=NBSOUS
      SEGINI CGEOMQ
      NSOUS=NBSOUS
      DO 3 ISOUS=1,NSOUS
         SOUGEO=CGEOME.LISOUS(ISOUS)
         SEGACT SOUGEO
         ITELEM=SOUGEO.ITYPEL
         CALL IDQUDI(ITELEM,ITQUAF,MYDISC)
         IF (IERR.NE.0) RETURN
* Est-ce un QUAF ?
         IF (ITQUAF.NE.ITELEM) THEN
            NBNN=NBNNE(ITQUAF)
            NBELEM=SOUGEO.NUM(/2)
            NBSOUS=0
            NBREF=0
*            write(ioimp,*) 'nmelem,nmeleq=',nmelem,nmeleq
*            write(ioimp,*) 'nbnn,nbelem=',nbnn,nbelem
            SEGINI MELEME
*     On met un flag négatif pour dire que le maillage de type QUAF peut
*     avoir maintenant des noeuds nuls
            ITYPEL=ITQUAF
            CALL KEEF(ITQUAF,MYDISC,
     $           MYFALS,
     $           MYLRF,
     $           IMPR,IRET)
            IF (IRET.NE.0) GOTO 9999
*            JG=NBNN
            SEGACT MYLRF
*            segprt,mylrf
*            stop 16
            NDDL=MYLRF.NPQUAF(/1)
            DO IBELEM=1,NBELEM
               DO IDDL=1,NDDL
                  NNQUA=MYLRF.NPQUAF(IDDL)
                  NNGLO=SOUGEO.NUM(IDDL,IBELEM)
                  NUM(NNQUA,IBELEM)=NNGLO
               ENDDO
            ENDDO
            SEGDES MYLRF
            CGEOMQ.LISOUS(ISOUS)=MELEME
            CGEOMQ.LISREF(ISOUS)=SOUGEO
         ELSE
            CGEOMQ.LISOUS(ISOUS)=SOUGEO
            CGEOMQ.LISREF(ISOUS)=0
         ENDIF
 3    CONTINUE
*      SEGDES CGEOME
*      CALL ECROBJ('MAILLAGE',CGEOME)
*      CALL PRLIST
*      stop 16
*
* Normal termination
*
      RETURN
*
* Format handling
*
*
* Error handling
*
 9999 CONTINUE
      MOTERR(1:8)='keef    '
      CALL ERREUR(1127)
      RETURN
*
* End of subroutine TRQUAF
*
      END