Sources Esope | Cast3M

convma
C CONVMA    SOURCE    OF166741  24/10/03    21:15:07     12022          
 
C=======================================================================
C=                            C O N V M A                              =
C=                            -----------                              =
C=                                                                     =
C=  Fonction :                                                         =
C=  ----------                                                         =
C=   Calcul des flux nodaux equivalents a une condition de convection  =
C=   forcee. Sousprogramme appele par CONVEC (convec.eso).             =
C=                                                                     =
C=  Parametres :  (E)=Entree   (S)=Sortie                              =
C=  ------------                                                       =
C=   IPMODE   (E)   Pointeur sur le segment MMODEL                     =
C=   IPCHCA   (E)   Pointeur sur le segment MCHELM de CARACTERISTIQUES =
C=   IPCHPO   (E)   Pointeur sur le CHPOINT contenant la temperature   =
C=                  exterieure le long de la surface de convection     =
C=   IPCONV   (S)   Pointeur sur le champ des flux equivalents         =
C=                                                                     =
C=  Variables locales :                                                =
C=  -------------------                                                =
C=   IPGEOM   Pointeur sur un MAILLAGE elementaire du CHPOINT          =
C=   IPOGEO   Pointeur sur un MAILLAGE commun au CHPOINT et au MASSIF  =
C=                                                                     =
C=  Denis ROBERT, le 28 avril 1988.                                    =
C=                                                                     =
C=  CORRECTIONS                                                        =
C=   CB215821 24/02/2016 : Correction d'une erreur dans les COQx       =
C=                         Mauvaise utilisation de MATMOD              =
C=                         Ajout d'une erreur 1050                     =
C=======================================================================
 
      SUBROUTINE CONVMA (IPMODE,IPCHCA,IPCHPO,IPCONV)
 
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
 
-INC PPARAM
-INC CCOPTIO
-INC CCHAMP
 
-INC SMCHAML
-INC SMCHPOI
-INC SMMODEL
-INC SMELEME
 
      SEGMENT MPTVAL
        INTEGER IPOS(NS),NSOF(NS),IVAL(NCOSOU)
        CHARACTER*16 TYVAL(NCOSOU)
      ENDSEGMENT
      SEGMENT NOTYPE
        CHARACTER*16 TYPE(NBTYPE)
      ENDSEGMENT
 
      PARAMETER (NINF=3)
      INTEGER INFOS(NINF)
      CHARACTER*(NCONCH) CONM
      CHARACTER*(LOCOMP) MOCOMP,NOMATT,NOMCQ
      CHARACTER*10 PEAU
      LOGICAL ltelq
 
C ===
C  0 - QUELQUES INITIALISATIONS ET SEGMENTS UTILES
C ===
      IPCONV=0
 
      NBROBL = 1
      NBRFAC = 0
      SEGINI,nomid
      nomid.LESOBL(1) = 'H       '
      MOMATR = nomid
 
      NBTYPE=1
      SEGINI,notype
      notype.TYPE(1) = 'REAL*8'
      MOTYR8 = notype
 
C CHAMP/ELT ELEMENTAIRE DES CHALEURS NODALES EQUIVALENTES
      N2=1
      SEGINI,MCHAM2
      MCHAM2.NOMCHE(1) = ' '
      MCHAM2.TYPCHE(1) = 'REAL*8'
      MCHAM2.IELVAL(1) = -99
      IPCHAM2 = MCHAM2
 
      L1=7
      N1=1
      N3=6
      SEGINI,MCHEL2
      MCHEL2.TITCHE ='CHALEUR'
      MCHEL2.IFOCHE = IFOUR
C*      MCHEL2.IFOCHE = IFOMOD
      MCHEL2.CONCHE(1) = ' '
      MCHEL2.IMACHE(1) = -99
      MCHEL2.ICHAML(1) = IPCHAM2
      MCHEL2.INFCHE(1,3) = NIFOUR
      MCHEL2.INFCHE(1,4) = 0
      MCHEL2.INFCHE(1,6) = 1
      IPCHEL2 = MCHEL2
 
C  1 - QUELQUES TRANSFORMATIONS SUR LES DONNEES
C ==============================================
C  1.1 - Creation d'un objet MAILLAGE contenant une seule fois tous les
C        points du CHPOINT IPCHPO (CHPOINT ACTIF EN E/S)
C        (fusion des maillages supports de tous les MSOUPO)
C =====
      MCHPOI=IPCHPO
c*      SEGACT,MCHPOI
      MSOUPO=IPCHP(1)
c*      SEGACT,MSOUPO
      IPGEOM=IGEOC
c*      SEGDES,MSOUPO
      ltelq=.false.
      DO i=2,IPCHP(/1)
        MSOUPO=IPCHP(i)
c*        SEGACT,MSOUPO
        IGEO1=IGEOC
c*        SEGDES,MSOUPO
        CALL FUSE(IPGEOM,IGEO1,IRET,ltelq)
        if (ierr.ne.0) goto 100
        IPGEOM=IRET
      ENDDO
c*      SEGDES,MCHPOI
c*      meleme=IPGEOM
c*      segact,meleme
C =====
C  1.2 - Recuperation du MMODEL (ACTIF EN E/S)
C =====
      MMODEL = IPMODE
c*      SEGACT,MMODEL
      NSOUS = mmodel.KMODEL(/1)
 
C =====
C  1.3 - Determination du support du champ de caracteristiques H
C =====
      CALL QUESUP(IPMODE,IPCHCA,0,0,iok,ISUPCA)
      IF (IERR.NE.0 .OR. iok.EQ.9999) THEN
        write(ioimp,*) 'CONVEC : ISUPCA incorrect'
        CALL ERREUR(21)
        goto 100
      ENDIF
 
C ========================================================
C  2 - BOUCLE SUR LES ZONES ELEMENTAIRES DU MODELE (iSou)
C ========================================================
      DO iSou= 1, NSOUS
 
        iOK = 0
 
        ICHELS = 0
        IPTEMP = 0
        IVAMAT = 0
        IPCHEQ = 0
 
C =====
C  2.1 - Analyse du sous-modele (iSou)
C =====
        IMODEL = KMODEL(iSou)
c*        SEGACT,IMODEL
 
        IPMAIL = imodel.IMAMOD
        CONM   = imodel.CONMOD
 
C    RECUPERATION DES CARACTERISTIQUES D'INTEGRATION
        NEF = imodel.NEFMOD
        NLG = NUMGEO(NEF)
        CALL TSHAPE(NLG,'GAUSS',IPINTE)
        if (ierr.NE.0) then
          call erreur(251)
          goto 100
        endif
 
        PEAU = '          '
C     Formulation COQx (COQ2,COQ3,COQ4,COQ6,COQ8)
        IF (NEF.EQ.44 .OR. NEF.EQ.27 .OR. NEF.EQ.56 .OR.
     &      NEF.EQ.49 .OR. NEF.EQ.41) THEN
          if (imodel.matmod(/2) .lt. 3) then
            moterr(1:4) = NOMTP(NEF)
            call erreur(1050)
            goto 100
          endif
 
          PEAU = imodel.MATMOD(3)
          IF     (PEAU .EQ. 'INFERIEURE') THEN
            nomatt = 'TINF'
            nomcq  = 'QINF'
          ELSEIF (PEAU .EQ. 'SUPERIEURE') THEN
            nomatt = 'TSUP'
            nomcq  = 'QSUP'
          ELSE
            moterr(1:8)  = 'MOT     '
            moterr(9:16) = PEAU(1:8)
            call erreur(11)
            goto 100
          ENDIF
C     Formulation STANDARD (pas COQx)
        ELSE
          nomatt = 'T   '
          nomcq  = 'Q   '
        ENDIF
 
C     ON GENERE UN CHAMELEM ELEMENTAIRE A PARTIR DU CHPOINT
C     DE TEMPERATURE EXTERIEURE ET DU MAILLAGE ELEMENTAIRE IPMAIL
        CALL CHAME1(IPMAIL,0,IPCHPO,' ',ICHELS,ISUPCA)
        if (ierr.ne.0) GOTO 10
        MCHEL1 = ICHELS
c*        SEGACT,MCHEL1
        MCHAM1 = MCHEL1.ICHAML(1)
c*        SEGACT,MCHAM1
C  Recherche de la bonne composante (meme s'il n'y en a qu'une)
        ivfr = 0
        DO i = 1, mcham1.ielval(/1)
          IF (mcham1.NOMCHE(i)(1:4).EQ.nomatt) ivfr=i
        ENDDO
        IF (ivfr.EQ.0) THEN
          MOTERR(1:4)  = nomatt
          MOTERR(5:30) = 'de TEMPERATURE exterieure'
          CALL ERREUR(77)
          GOTO 10
        ENDIF
        IPTEMP = mcham1.IELVAL(ivfr)
 
C     RECUPERATION DU COEFFICIENT D'ECHANGE
C     ON GENERE UN CHAMELEM ELEMENTAIRE DE CARACTERISTIQUES ET 
C     DU MAILLAGE ELEMENTAIRE IPMAIL
        CALL IDENT(IPMAIL,CONM,IPCHCA,0,INFOS,IOK)
        CALL KOMCHA(IPCHCA,IPMAIL,CONM,MOMATR,MOTYR8,1,INFOS,3,IVAMAT)
        if (ierr .ne. 0) goto 10
        MPTVAL = IVAMAT
        if (mptval.ival(/1) .lt. 1) then
          call erreur(472)
          goto 10
        endif
        IPCOEF = mptval.IVAL(1)
 
C     CALCUL DES FLUX NODAUX EQUIVALENTS
        IF (NLG.EQ.1) THEN
          CALL INTCN0(IPTEMP,IPCOEF,IPMAIL,IPINTE,IPCHEQ)
        ELSE IF (NLG.EQ.2.OR.NLG.EQ.3) THEN
          CALL INTCN1(IPTEMP,IPCOEF,IPMAIL,IPINTE,IPCHEQ)
        ELSE IF (NLG.EQ.4.OR.NLG.EQ.6.OR.NLG.EQ.8.OR.
     &           NLG.EQ.10) THEN
          CALL INTCN2(IPTEMP,IPCOEF,IPMAIL,IPINTE,IPCHEQ)
        ENDIF
        IF (ierr.ne.0) goto 10
 
C    CHAMELEM ELEMENTAIRE DES CHALEURS NODALES EQUIVALENTES
        MCHEL2 = IPCHEL2
c*        segact,mchel2*mod
        MCHEL2.IMACHE(1) = IPMAIL
        MCHEL2.CONCHE(1) = CONM
C*        MCHEL2.INFCHE(1,4) = IPINTE
C*        MCHEL2.INFCHE(1,6) = 6
        MCHAM2 = IPCHAM2
c*        segact,mcham2*mod
        MCHAM2.NOMCHE(1) = nomcq
        MCHAM2.IELVAL(1) = IPCHEQ
 
C     ON TRANSFORME LE CHAMELEM EN CHPOINT
        CALL CHAMPO(IPCHEL2,0,IPCHP1,idum)
        if (ierr.ne.0) goto 10
 
C     ON REGROUPE,LE CAS ECHEANT,LES DIFFERENTS CHPOINTS
        IF (iSou.GT.1) THEN
          CALL ADCHPO(IPCHP1,IPCONV,IPCRET,1.D0,1.D0)
          CALL DTCHPO(IPCHP1)
          CALL DTCHPO(IPCONV)
          IF (IPCRET.EQ.0) GOTO 10
          IPCONV=IPCRET
        ELSE
          IPCONV=IPCHP1
        ENDIF
c* ? interet
        CALL ACTOBJ('CHPOINT ',IPCONV,1)
 
        iOK=1
 10     continue
c* iptemp peut provenir d'un preconditionnement : donc a ne pas detruire
c*        if (iptemp.ne.0) then
c*          melval = iptemp
c*          segsup,melval
c*        endif
c* ichels peut provenir d'un preconditionnement : donc a ne pas detruire
c*        if (ichels.ne.0) then
c*          mchel1 = ichels
c*          segsup,mchel1
c*        endif
        if (ipcheq.ne.0) then
          melval = ipcheq
          segsup,melval
        endif
        if (ivamat.ne.0) then
          mptval = ivamat
          segsup,mptval
        endif
        IF (iOK.EQ.0) GOTO 100
 
      ENDDO
C =============================
C  2 - FIN DE LA BOUCLE (iSou)
C =============================
 
C Menage final
 100  CONTINUE
      nomid = MOMATR
      SEGSUP,nomid
      notype = MOTYR8
      SEGSUP,notype
 
      mchaml = IPCHAM2
      mchelm = IPCHEL2
      SEGSUP,mchaml,mchelm
 
c      return
      END