Télécharger fform1.eso

Retour à la liste

fform1
C FFORM1    SOURCE    CB215821  24/04/12    21:15:58     11897          
        SUBROUTINE FFORM1(mymod,mchelm,ichfac)
      IMPLICIT INTEGER(I-N)
        IMPLICIT REAL*8 (A-H,O-Z)
C
C            SOUS-PROGRAMME ASSOCIE A L'OPERATEUR FFOR
C      (LECTURE ET VERIFICATION DES DONNEES PUIS AIGUILLAGE)
C
C__________________________________________________________________
C APPEL :
C
C 3D    CH2 = FFOR MODL1 (ENTI1) (FLOT1) ('SYME' P1 P2 P3) ('NNOR')  ;
C 2D    CH2 = FFOR MODL1 (ENTI1) (FLOT1) ('SYME' P1 P2 )   ('NNOR')  ;
C CONV  CH2 = FFOR MODL1 (ENTI1) 'CVXE'   ;
C AXIS  CH2 = FFOR MODL1 (ENTI1) ('NGAU' ENTI2) ('CVXE') ('NNOR')   ;
C
C
C 03/96 : option supplementaire pour tenir compte de l'absorption du
C         milieu:
C             'ABSO' EXTINC ;
C      pour simplifier la lecture on demande que ce coef. soit negatif
C
C 09/02: on donne le nombre de points d'integration pour le traitement
C        des faces proches en AXIS (cf 'NGAU')
C__________________________________________________________________
C OPERANDES :
C
C       CH2      'MCHAML'   FACTEURS DE FORME
C       MODL1    'MMODEL'   STRUCTURE MODELISEE (CONTOUR OU ENVELOPPE)
C       ENTI1    'ENTIER'   DISCRETISATION ANGULAIRE EN 2D-PLAN OU
C                           3D-CAS GENERAL
C       FLOT1    'FLOTTANT' FACTEUR DE DECOUPAGE DES ELEMENTS
C       CVXE     'MOT CLE'  MOT CLE POUR LES CAVITES CONVEXES
C       SYME     'MOT CLE'  MOT CLE DEFINISSANT UN AXE OU UN PLAN
C                           DE SYMETRIE
C       P1,P2,P3 'POINT'    POINTS DEFINISSANT L'AXE OU LE PLAN DE
C                           SYMETRIE
C       NGAU     'MOT CLE'  EN AXISYMETRIQUE
C       ENTI2    'ENTIER'   nombre de points d'integration
C
C       ABSO                mot-clé pour un milieu absorbant
C       EXTINC              coefficient d'absorption
C__________________________________________________________________
C
C
 
-INC PPARAM
-INC CCOPTIO
-INC SMMODEL
-INC SMCHAML
C
        POINTEUR MYMOD.MMODEL
C       ___________________________________________________________
C       Stockage de numeros de points
        SEGMENT ,LISTEN
          INTEGER LECT(NBE)
        ENDSEGMENT
        POINTEUR IAXE.LISTEN
C       ___________________________________________________________
C       Stockage d'informations concernant le type des éléments
        SEGMENT ,INFOEL
          LOGICAL KCOQ(N1),KQUAD(N1)
        ENDSEGMENT
C       ___________________________________________________________
C
        CHARACTER*4  MOTCLE
        LOGICAL MCVX,MSYM,MGAUS,MABS
C
C__________________________________________________________________
C
        MCVX  = .FALSE.
        MSYM  = .FALSE.
        MGAUS = .FALSE.
        MABS  = .FALSE.
        KNOR = 1
        IAXE = 0
        EXTINC = -1.D-5
C
C      -----------------------------------------------------
C      On va vérifier que le TYPE DES ÉLÉMENTS des maillages
C      sur lequel repose le modèle CONVIENT .
C      et le type de modèle
C
       SEGACT MYMOD
       N1 = MYMOD.KMODEL(/1)
       iy=0
   20  iy=iy+1
       if( iy.gt.mymod.kmodel(/1)) then
         call erreur (19)
         return
       endif
       imodel=mymod.kmodel(iy)
       segact imodel
       if (formod(1).ne.'THERMIQUE') goto 20
       nmat=matmod(/2)
       if (matmod(2).ne.'RAYONNEMENT') goto 20
       if (matmod(3).ne.'CAVITE')  go to 20
       if (imatee.ne.4) go to 20
       inatu=inatuu
* pour la valeur de inatu voir subroutine nomate
       if( inatu.eq.2)then
            knor=0
       elseif(inatu.eq.3) then
            MSYM = .TRUE.
       elseif(inatu.eq.4) then
            MCVX = .TRUE.
       elseif(inatu.eq.5) then
            MSYM = .TRUE.
            MCVX = .TRUE.
       elseif(inatu.eq.6) then
            knor=0
            MCVX = .TRUE.
       elseif(inatu.eq.7) then
            MSYM = .TRUE.
            knor=0
       elseif(inatu.eq.8) then
            MSYM = .TRUE.
            MCVX = .TRUE.
            knor=1
       elseif(inatu.ne.1) then
            write(6,*) ' pb dans fforme'
            write(6,*)  '  inatu ' , inatu
            call erreur(5)
       endif
       imail= imamod
       ngax=ivamod(1)
       int=ivamod(2)
       npax=20
       npax=max ( int,npax)
       SEGINI INFOEL
* recherche du coefficient d'absorption
*
       if( mchelm.ne.0) then
        segact mchelm
        do iy=1,imache(/1)
*        write(6,*) imamod,imache(iy),conche(iy),conmod
          if( imache(iy).eq.imamod.and.conche(iy).eq.conmod) then
           mchaml=ichaml(iy)
           segact mchaml
             do it=1,nomche(/2)
               if( nomche(it).eq.'CABS' ) THEN
                  melval=ielval(it)
                  segact melval
                  extinc=-velche(1,1)
                  mabs=.true.
                  go to 8
               endif
             enddo
           endif
       enddo
    8  continue
      endif
*      write(6,*) ' extinc',extinc
*       write(6,*) ' knor mcvx , msym , mgaus mabs'
*       write(6,*) knor,mcvx , msym , mgaus,mabs
 
C
       DO 10 ITYP=1,N1
C
          IMODEL = MYMOD.KMODEL(ITYP)
          SEGACT IMODEL
C
C         la formulation est simple a priori
C
         IF(FORMOD(1).NE.'THERMIQUE'.or.matmod(2).ne.'RAYONNEMENT') THEN
           CALL ERREUR(21)
           RETURN
         ENDIF
*         write(6,*) ' nefmod ' , nefmod
C
C      On va rega Crder quelle est la nature de l'élément
          IF (IDIM.EQ.3) THEN
 
                IF ((NEFMOD.EQ.4).OR.(NEFMOD.EQ.8)) THEN
C                  TRI3 ou QUA4
                   KQUAD(ITYP)=.FALSE.
                   KCOQ(ITYP) =.FALSE.
                ELSEIF ((NEFMOD.EQ.27).OR.(NEFMOD.EQ.49)) THEN
C                  COQ3 ou COQ4
                   KQUAD(ITYP)=.FALSE.
                   KCOQ(ITYP) =.TRUE.
                ELSEIF ((NEFMOD.EQ.6).OR.(NEFMOD.EQ.10)) THEN
C                  TRI6 ou QUA8
                   KQUAD(ITYP)=.TRUE.
                   KCOQ(ITYP) =.FALSE.
                ELSEIF ((NEFMOD.EQ.56).OR.(NEFMOD.EQ.41)) THEN
C                  COQ6 ou COQ8
                   KQUAD(ITYP)=.TRUE.
                   KCOQ(ITYP) =.TRUE.
                ELSE
                   CALL ERREUR(16)
                   RETURN
                ENDIF
C
          ELSEIF (IDIM.EQ.2) THEN
C
                IF (NEFMOD.EQ.2) THEN
C                  SEG2
                   KQUAD(ITYP)=.FALSE.
                   KCOQ(ITYP) =.FALSE.
                ELSEIF (NEFMOD.EQ.44) THEN
C                  COQ2
                   KQUAD(ITYP)=.FALSE.
                   KCOQ(ITYP) =.TRUE.
                ELSEIF (NEFMOD.EQ.3) THEN
C                  SEG3
                   KQUAD(ITYP)=.TRUE.
                   KCOQ(ITYP) =.FALSE.
                ELSE
                   CALL ERREUR(16)
                   RETURN
                ENDIF
C
          ELSE
                CALL ERREUR(14)
                RETURN
          ENDIF
 
 10    CONTINUE
 
       SEGDES INFOEL
C
C
C      ----------------------------------------------------
C      Orientation  vers les différents sous-programmes
C
       IF  (IFOMOD.NE.0) THEN
C      On n'est pas en mode axisymétrique
C
            IF (MCVX.AND.(.NOT.MSYM)) THEN
C           on n'a recu que CVXE
                GOTO 100
            ELSEIF (MSYM) THEN
C           il faut lire des points pour le cas général
                GOTO 200
            ELSE
C           cas général
                GOTO 210
            ENDIF
C
       ELSE
C      On est en mode axisymétrique
                GOTO 300
C
       ENDIF
C
C**********************************************************
C
C
C
C********************
C CAS CONVEXE
C********************
C
 100   CALL LIRENT(INT1,0,IRETOU)
       IF (IRETOU.NE.0) THEN
           INT=INT1
       ELSE
           INT=3
       ENDIF
*         write(6,*) ' int ', int
       CALL FACCVX(MYMOD,INFOEL,INT,ICHFAC)
 
       GOTO 900
C
C
C********************
C CAS GENERAL
C********************
C
C----cas avec 'SYME' => lecture des points
C
 200   segact imodel
       ip1 = ivamod(3)
       ip2 = ivamod(4)
       NBE = IDIM
       SEGINI ,IAXE
       IAXE.LECT(1) = IP1
       IAXE.LECT(2) = IP2
       IF (IDIM.EQ.3) THEN
          ip3=ivamod(5)
          iaxe.lect(3)=ip3
       ENDIF
       SEGDES IAXE
C
C----suite du cas général
C
 210   CALL LIRENT(INT1,0,IRETOU)
       IF (IRETOU.NE.0) THEN
            IF(IDIM.EQ.3) THEN
               LRES=MIN0(INT1,100)
            ELSE
               LRES=MIN0(INT1,1000)
            ENDIF
       ELSE
            IF(IDIM.EQ.3) THEN
               LRES=50
            ELSE
               LRES=200
            ENDIF
       ENDIF
*      write(6,*) '  lres  ' , lres
 
 
*       IF (MABS) THEN
*         CALL LIRREE(FLO2,0,IRETO2)
*         CALL LIRREE(FLO1,0,IRETOU)
*         IF(FLO2.LT.(-1.D-5)) THEN
*           EXTINC = -FLO2
*         ELSE
*           EXTINC = -FLO1
*           FLO1 = FLO2
*           IRETOU=IRETO2
*         ENDIF
*       ELSE
*         CALL LIRREE(FLO1,0,IRETOU)
*       ENDIF
*       IF (IRETOU.NE.0) THEN
*            IF(IDIM.EQ.3) THEN
*               XDEC=MIN(FLO1,2.D0)
*            ELSE
*               XDEC=MIN(FLO1,10.D0)
*            ENDIF
*       ELSE
            IF(IDIM.EQ.3) THEN
               XDEC=0.5
            ELSE
               XDEC=5.D0
            ENDIF
*       ENDIF
*              write(6,*) ' xdec ' , xdec
C
C
       IF (IDIM.EQ.3) THEN
*               write(6,*) ' appel a facgen'
*         write(6,*) LRES,XDEC,IAXE,KNOR,EXTINC
           CALL FACGEN(MYMOD,INFOEL,LRES,XDEC,IAXE,KNOR,ICHFAC,EXTINC)
       ELSE
*           write(6,*) ' appel a facge2'
*         write(6,*) LRES,XDEC,IAXE,KNOR,EXTINC
*        write(6,*) ( kcoq(iou),kquad(iou),iou=1,kcoq(/1))
 
           CALL FACGE2(MYMOD,INFOEL,LRES,XDEC,IAXE,KNOR,ICHFAC,EXTINC)
       ENDIF
       IF (IAXE.NE.0)   SEGSUP IAXE
C
       GOTO 900
C
C********************
C CAS AXISYMETRIQUE
C********************
C
 
 300   CONTINUE
 
C      valeurs par defaut
 
       NGAX=10
       NPAX=20
 
       CALL LIRENT(INT1,0,IRETO1)
       CALL LIRENT(INT2,0,IRETO2)
 
       IF (IRETO2.NE.0) THEN
         NGAX = MIN0(INT1,10)
         NPAX = MIN0(INT2,1000)
       ELSEIF (MGAUS)  THEN
         NPAX = MIN0(INT1,1000)
       ELSEIF (IRETO1.NE.0) THEN
         NGAX=MIN0(INT1,10)
       ENDIF
 
C      WRITE(6,*) ' FFOR NG NP ',NGAX,NPAX
 
       IF (MCVX) THEN
          KACHE = 0
       ELSE
          KACHE = 1
       ENDIF
C
       IF(MABS) THEN
         CALL LIRREE(FLO1,0,IRETOU)
           IF (IRETOU.NE.0) THEN
            EXTINC=-FLO1
           ENDIF
       ENDIF
 
       CALL FACAXI(MYMOD,INFOEL,NPAX,NGAX,KACHE,KNOR,ICHFAC,EXTINC)
C
C**********************************************************
C
 900    SEGSUP ,INFOEL
        segact mymod
        mchelm=ICHFAC
        segact mchelm*mod
        do i=1,mymod.kmodel(/1)
          imodel=mymod.kmodel(i)
          segact imodel
          conche(i)=conmod
        enddo
C   Ecriture du chamelem facteur de forme
*        CALL ECROBJ('MCHAML ',ICHFAC)
        END
 
 
 
 
 
 
 

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