C CHAME1    SOURCE    MB234859  25/09/08    21:15:09     12358          

C____________________________________________________________________*
C                                                                    *
C     transformation de CHPOINT en MCHAML                            *
C                                                                    *
C     entrees:                                                       *
C     ________                                                       *
C                                                                    *
C     ipmail       pointeur sur un maillage                          *
C ou  ipmodl       pointeur sur un mmodel                            *
C     ipchpo       pointeur sur le chpoint                           *
C     cha          chaine de caractere contenant un sous type eventuel
C     isup         indique le type de support demande :              *
C                  1 le mchaml est laisse aux noeuds                 *
C                  2 au centre de gravite                            *
C                  3 aux points de gauss de la raideur               *
C                  4 aux points de gauss de la masse                 *
C                  5 aux points de gauss des contraintes             *
C                  6 aux point de gauss de la thermique & diffusion  *
C                    & metallurgie                                   *
C                                                                    *
C     sorties:                                                       *
C     ________                                                       *
C                                                                    *
C     ipchel       pointeur sur le mchaml resultat                   *
C                                                                    *
C     Remarque : le passage du mchaml sur un autre support que les   *
C     --------   noeuds n'est possible que si l'on a donne un mmodel *
C                                                                    *
C                le traitement d'harmoniques de fourier n'est pas    *
C                implemente                                          *
C                                                                    *
C____________________________________________________________________*
C                                                                    *
      SUBROUTINE CHAME1(IPMAIL,IPMODL,IPCHPO,CHA,IPCHEL,ISUP)

      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)

-INC PPARAM
-INC CCOPTIO
-INC CCGEOME
-INC CCASSIS
-INC CCPRECO
C==DEB= FORMULATION HHO == Include specifique ==========================
-INC CCHHOPA
C==FIN= FORMULATION HHO ================================================

-INC SMCHAML
-INC SMCHPOI
-INC SMINTE
-INC SMMODEL
-INC SMELEME
-INC SMCOORD

      COMMON/cham1c/IPARA1,IPARA2
      EXTERNAL CHAM1I
      LOGICAL  BTHRD

      SEGMENT SPARA1
        INTEGER NBTHR1
        INTEGER IPCH1
        INTEGER IPTP1
        INTEGER IPTR1
      ENDSEGMENT

      SEGMENT SPARA2
        INTEGER NBTHRD
        INTEGER IISUP
        INTEGER IPSAU
        INTEGER IPMOD
        INTEGER IPCHE
        INTEGER IPTPR
        INTEGER IPTRA
      ENDSEGMENT

      SEGMENT ISAUT(IVAL,NSOUS)
      SEGMENT ICPR(nbpts)

      SEGMENT MTRA2
C      Copie du CHPOINT dans MTRA2 pour aller plus vite ensuite
       CHARACTER*(LOCOMP) INCO(N2)
       REAL*8      BB(NX,N2)
C        INCO  : Nom des INCONNUES du CHPOINT
C        BB    : Valeurs au noeuds du MMODEL (associees au ICPR)
C                NX : Nombre de noeuds differents dans le MODELE
C                N2 : Nombre de composantes dans le CHPOINT
      ENDSEGMENT

      CHARACTER*(*) CHA
      CHARACTER*(LOCOMP) MOCOMP
      CHARACTER*1 MO1,VID1

C   soutyp = sous-type du champ par element resultat
C   lsouty = longueur utile de la chaine "soutyp"
      INTEGER LSOUTY
      CHARACTER*72 SOUTYP
      LOGICAL ICOQ

      if (isup.lt.1 .or. isup.gt.6) then
        write(ioimp,*) 'CHAME1 : isup < 1 or isup > 6'
        call erreur(5)
      endif

c*      write(ioimp,*) 'chame1 ',ipmAIL,IPMODL,IPCHPO,CHA,ISUP
*  preconditionnement on regarde si on a sauve le resultat
*  on ne fait l'horodatage que pour le chp par mesure d'economie
      ith=oothrd
      ihomai = 0
      ihomod = 0
      if (ipmodl.ne.0.and.ipmail.ne.0) ipmail=0
      if (ipmail.ne.0) call oooho1(ipmail,ihomai)
      if (ipmodl.ne.0) call oooho1(ipmodl,ihomod)
      call oooho1(ipchpo,ihochp)
      do 100 iprec=1,nprcha
       if (iprma(iprec,ith).ne.ipmail) goto 100
       if (iprhoa(iprec,ith).ne.ihomai) goto 100
       if (iprmo(iprec,ith).ne.ipmodl) goto 100
       if (iprhom(iprec,ith).ne.ihomod) goto 100
       if (iprchp(iprec,ith).ne.ipchpo) goto 100
       if (iprhoc(iprec,ith).ne.ihochp) goto 100
       if (iprsu(iprec,ith).ne.isup  ) goto 100
       if (iprcha(iprec,ith).ne.cha  ) goto 100
       if (iprcnf(iprec,ith).ne.mcoord) goto 100
*  preconditionnement trouve
       ipchel=iprchl(iprec,ith)
**     if(ith.eq.1)
**   > write(6,*) ' preconditionnement trouve ',iprec,ith,ipchel
       call actobj('MCHAML',ipchel,1)
       return
 100  continue

      IPARA1= 0
      IPARA2= 0

      NT1   = 1
      NT2   = 1
      IOPTIM= 100

      IPCHEL= 0
      VID1  = ' '
      MO1   = ' '

      ither = 0
      idiff = 0
      imeta = 0
C
C   Informations sur le chpoint
C
      MCHPOI = IPCHPO

C     Renvoie le nombre de composantes
      CALL NBCOMP(MCHPOI,'CHPOINT ',N2)

      NSOUPO = IPCHP(/1)

      ICOQ=.FALSE.
      DO ISOUPO=1,NSOUPO
        MSOUPO=IPCHP(ISOUPO)
        NCOMPO=NOCOMP(/2)
        DO ICO=1,NCOMPO
          MOCOMP=MSOUPO.NOCOMP(ICO)
          IF (MOCOMP(1:4).EQ.'TINF'.OR.MOCOMP(1:4).EQ.'TSUP') THEN
            ICOQ=.TRUE.
            GOTO 1
          ENDIF
        ENDDO
      ENDDO
 1    CONTINUE
C
C     on cree l'objet maillage contenant tous les points du chpoint
      IF (IPMAIL.NE.0) THEN
         IPT1=IPMAIL
         NSOU1 = IPT1.LISOUS(/1)
         NSOUS = MAX(1,NSOU1)
      ELSE IF (IPMODL.NE.0) THEN
         MMODEL = IPMODL
         NSOUS  = KMODEL(/1)
      ENDIF
C
C     initialisation du segment descripteur du champ par element
C
      N1 = NSOUS
      N3 = 6
      MO1 = CHA(1:1)
      IF (MO1.EQ.VID1) THEN
         L1=8
         SOUTYP=MTYPOI
      ELSE
         L1=LEN(CHA)
         SOUTYP=CHA
      ENDIF

      NX    =0

C     Dimensionnement de ISAUT
      IVAL=6
      IF (ICOQ) IVAL = IVAL + 2

      IF(OOTHRD .NE.0) call oooprl(1)
      SEGINI,ICPR,ISAUT
      IF(OOTHRD .NE.0) call oooprl(0)

      NSCHM = 0

      DO 19 ISOUS = 1, NSOUS

         IPMINT=0

         IF (IPMAIL.NE.0) THEN

            ISUP1 = 1

            IF (NSOU1.GE.1) THEN
               IPT2=IPT1.LISOUS(ISOUS)
            ELSE
               IPT2=IPMAIL
            ENDIF

         ELSE IF (IPMODL.NE.0) THEN

            ISUP1 = ISUP

            IMODEL = KMODEL(ISOUS)

            IPT2 = IMAMOD
            MELE = NEFMOD

C==DEB= FORMULATION HHO ================================================
C= On ne fait pas de MCHAML pour les HHO (a voir par la suite...)
            IF (MELE.EQ.HHO_NUM_ELEMENT) THEN
              GOTO 19
            END IF
C==FIN= FORMULATION HHO ================================================

c           pour les elements MULT, on autorise que les MCHAML aux noeuds
            if (ISUP1.ne.1) then
              if(mele.eq.22 .OR. mele.eq.259) goto 19
            endif

            if (formod(1)(1:8).eq.'LIAISON ') then
C             ne fait rien si le maillage de LIAISON n'appartient pas au CHPOINT

              IVAL1 = IPT2.num(1,1)
              DO I=1,NSOUPO
                MSOUPO=IPCHP(I)
                MELEME=IGEOC
                do jno = 1, num(/2)
                  if (num(1,jno).eq.IVAL1) goto 191
                enddo
                goto 19
              ENDDO
 191          CONTINUE
            endif

            NPINT = INFMOD(1)
C
C           Changement de support si besoin selon la formulation ?
            IF (ISUP1 .NE. 1) THEN
              NFOR = FORMOD(/2)
              CALL PLACE(FORMOD,NFOR,icont,'CONTACT         ')
              CALL PLACE(FORMOD,NFOR,ichph,'CHANGEMENT_PHASE')
              IF (icont.NE.0 .OR. ichph.NE.0) THEN
                ISUP1 = 1
              ELSE
                CALL PLACE(FORMOD,NFOR,ither,'THERMIQUE')
                CALL PLACE(FORMOD,NFOR,idiff,'DIFFUSION')
                CALL PLACE(FORMOD,NFOR,imeta,'METALLURGIE')
                IF (ither.NE.0 .OR. idiff.NE.0 .OR. imeta.NE.0) THEN
                  nmat = matmod(/2)
                  CALL PLACE(matmod,nmat,iray,'RAYONNEMENT')
C                 Support 6 SAUF pour le RAYONNEMENT...
C                 Les cas-tests de RAYONNEMENT sont en erreur sans ca...
                  IF (iray.EQ.0) THEN
                    IF (ISUP1.GT.2) ISUP1 = 6
                  ENDIF
                ENDIF
              ENDIF
            ENDIF
C
C           on recupere le pointeur sur le minte correspondant a isup1
C
            IF (ISUP1.GT.1) THEN
C              cas de la THERMIQUE(sauf RAYONNEMENT) OU DIFFUSION OU METALLURGIE
               IF (ither.NE.0 .OR. idiff.NE.0 .OR. imeta.NE.0) THEN
                 IF ( ISUP1 .EQ. 2) THEN
                   CALL TSHAPE(MELE,'GRAVITE',IPMINT)
cc                 ELSE IF ( ISUP1 .EQ. 6) THEN
                 ELSE
                   CALL TSHAPE(MELE,'GAUSS  ',IPMINT)
                 ENDIF
                 IF (IERR.NE.0) RETURN
                 IELE = NUMGEO(MELE)
                 NBNN = NBNNE(IELE)
               ELSE
                 IPMINT=INFMOD(2+ISUP1)
                 IELE  =INFELE(14)
                 NBNN  =NBNNE(IELE)
               ENDIF
C
C              initialisation de ipore pour milieu poreux
C
               IPORE=0
               IF(MELE.GE.79 .AND.MELE.LE.83 ) IPORE=NBNN
               IF(MELE.GE.173.AND.MELE.LE.177) IPORE=NBNN
               IF(MELE.GE.178.AND.MELE.LE.182) IPORE=NBNN
C              cas XFEM il faut seulement les 4 premier noeuds (support geometrique)
C*??               IF (MELE.EQ.263 .OR. MELE.EQ.264) IPORE=NBNN
               IF (MELE.GE.263) IPORE=NBNN

               IF(IPORE .EQ. 0)THEN
                 MINTE         =IPMINT
                 ISAUT(5,ISOUS)=SHPTOT(/2)
               ELSE
                 ISAUT(5,ISOUS)=IPORE
               ENDIF
            ENDIF
C
C           Quels sont les modeles concernes par TINF et TSUP
            IF (ICOQ) THEN
              ISAUT(IVAL-1,ISOUS)=0
              IPNOMC = 0
              CALL PLACE(FORMOD,NFOR,ITHER,'THERMIQUE')
              IF (ITHER.NE.0) THEN
                IPNOMC = LNOMID(1)
              ENDIF
              CALL PLACE(FORMOD,NFOR,IMECA,'MECANIQUE')
              IF (IMECA.NE.0) THEN
                IPNOMC = LNOMID(8)
              ENDIF
              IF (IPNOMC.EQ.0) GOTO 192
              NOMID = IPNOMC
              NCOBL = LESOBL(/2)
              DO IJC = 1,NCOBL
                MOCOMP = LESOBL(IJC)
                IF (MOCOMP(1:4).EQ.'TINF'.OR.MOCOMP(1:4).EQ.'TSUP') THEN
                  ISAUT(IVAL-1,ISOUS)=1
                  GOTO 192
                ENDIF
              ENDDO
 192          CONTINUE
            ENDIF
C
         ELSE
           CALL ERREUR(5)
           RETURN
         ENDIF

         NSCHM = NSCHM + 1

         NBNO = IPT2.NUM(/1)
         N1EL = IPT2.NUM(/2)

C        Remplissage de l'ICPR a partir des noeuds du MMODEL
C          L'utilisation d'un ICPR par MMODEL limite l'utilisation de
C          memoire en parallele dans les ASSISTANTS
         DO IEL=1,N1EL
           DO INO=1,NBNO
              INOEU=IPT2.NUM(INO,IEL)
              IF(ICPR(INOEU) .EQ. 0)THEN
                NX=NX+1
                ICPR(INOEU)=NX
              ENDIF
           ENDDO
         ENDDO

         IF(IPMINT .EQ. 0)THEN
           N1PTEL=NBNO
         ELSE
           MINTE =IPMINT
           N1PTEL=SHPTOT(/3)
         ENDIF
         NT2 = MAX(NT2,N1EL*N1PTEL)

         ISAUT(1,ISOUS) = IPT2
         ISAUT(2,ISOUS) = N1EL
         ISAUT(3,ISOUS) = N1PTEL
         ISAUT(4,ISOUS) = IPMINT
         ISAUT(6,ISOUS) = ISUP1

 19   CONTINUE

C     Creation d'un MAXIMUM de SEGMENTS dans un LOCK
      N1 = NSCHM
      IF(OOTHRD .NE.0) call oooprl(1)
      SEGINI,MCHELM

      TITCHE=SOUTYP
      IFOCHE=IFOUR

      N2PTEL=0
      N2EL  =0

      ischm = 0
      DO ISOUS = 1, NSOUS
        IF (ISAUT(1,ISOUS).NE.0) THEN
          ischm = ischm + 1
          SEGINI,MCHAML
          ICHAML(ischm) = MCHAML
          N1EL   = ISAUT(2,ISOUS)
          N1PTEL = ISAUT(3,ISOUS)
          DO ICOMP=1,N2
            SEGINI,MELVAL
            IELVAL(ICOMP)=MELVAL
          ENDDO
          IF (ICOQ) THEN
            IF (ISAUT(IVAL-1,ISOUS).EQ.1) THEN
              SEGINI,MELVAL
              ISAUT(IVAL,ISOUS) = MELVAL
            ENDIF
          ENDIF
        ENDIF
      ENDDO
      IF (ischm.NE.NSCHM) THEN
        write(ioimp,*) 'CHAME1 : Incompatibilite ischm & NSCHM'
        CALL ERREUR(5)
      ENDIF

      SEGINI,MTRA2
      IF(OOTHRD .NE.0) call oooprl(0)

      NCO = 0
      DO ISOUPO=1,NSOUPO
        MSOUPO=IPCHP(ISOUPO)
        MELEME=IGEOC
        NT1   =MAX(NT1,NUM(/2))
        NC    =MSOUPO.NOHARM(/1)
        DO 101 ICO=1,NC
          MOCOMP=MSOUPO.NOCOMP(ICO)
          DO K=1,NCO
            IF (MOCOMP .EQ. MTRA2.INCO(K)) GOTO 101
          ENDDO
          NCO = NCO + 1
          K   = NCO
          MTRA2.INCO(NCO)=MOCOMP
 101    CONTINUE
      ENDDO

C----------------------------------------------------------------------C
C  Remplissage du MTRA2
C----------------------------------------------------------------------C
      NBTHR=MIN(MAX(NT1/IOPTIM,1),NBTHRS)
      IF ((NBTHR .EQ. 1) .OR. (NBTHRS .EQ. 1) .OR. (OOTHRD .GT. 0)) THEN
C       CB215821 : DESACTIVE LA PARALLELISATION PTHREAD LORSQUE ON EST
C                  DEJA DANS LES ASSISTANTS
        NBTHR = 1
        BTHRD = .FALSE.
      ELSE
        BTHRD = .TRUE.
        CALL THREADII
      ENDIF

      IF (BTHRD) THEN
C       Remplissage du 'COMMON/cham1c'
        SEGINI,SPARA1
        IPARA1=SPARA1
        IPARA2=0

        SPARA1.NBTHR1=NBTHR
        SPARA1.IPCH1 =MCHPOI
        SPARA1.IPTP1 =ICPR
        SPARA1.IPTR1 =MTRA2

        DO ith=2,NBTHR
          CALL THREADID(ith,CHAM1i)
        ENDDO
        CALL CHAM1i(1)

C       Attente de la fin de tous les threads en cours de travail
        DO ith=2,NBTHR
          CALL THREADIF(ith)
        ENDDO

C       On libère les Threads
        CALL THREADIS
        SEGSUP,SPARA1

      ELSE
C       Appel de la SUBROUTINE qui fait le travail
        ith=1
        CALL CHAM11(NBTHR,ith,MCHPOI,ICPR,MTRA2)
      ENDIF

C----------------------------------------------------------------------C
C  Remplissage du MCHAML
C----------------------------------------------------------------------C

      NBTHR=MIN(MAX(NT2/IOPTIM,1),NBTHRS)
      IF ((NBTHR .EQ. 1) .OR. (NBTHRS .EQ. 1) .OR. (OOTHRD .GT. 0)) THEN
C       CB215821 : DESACTIVE LA PARALLELISATION PTHREAD LORSQUE ON EST
C                  DEJA DANS LES ASSISTANTS
        NBTHR = 1
        BTHRD = .FALSE.
      ELSE
        BTHRD = .TRUE.
        CALL THREADII
      ENDIF

      IF (BTHRD) THEN
C       Remplissage du 'COMMON/cham1c'
        SEGINI,SPARA2
        IPARA1=0
        IPARA2=SPARA2

        SPARA2.NBTHRD=NBTHR
        SPARA2.IISUP =ISUP
        SPARA2.IPSAU =ISAUT
        SPARA2.IPMOD =IPMODL
        SPARA2.IPCHE =MCHELM
        SPARA2.IPTPR =ICPR
        SPARA2.IPTRA =MTRA2

        DO ith=2,NBTHR
          CALL THREADID(ith,CHAM1i)
        ENDDO
        CALL CHAM1i(1)

C       Attente de la fin de tous les threads en cours de travail
        DO ith=2,NBTHR
          CALL THREADIF(ith)
        ENDDO

C       On libere les Threads
        CALL THREADIS
        SEGSUP,SPARA2

      ELSE
C       Appel de la SUBROUTINE qui fait le travail
        ith=1
        CALL CHAM12(NBTHR,ith,ISUP,ISAUT,IPMODL,MCHELM,ICPR,MTRA2)
      ENDIF

C     Modification pour les modeles avec TINF ou TSUP
      IF (ICOQ.AND.IPMODL.NE.0) THEN
        ischm = 0
        DO ISOUS = 1, NSOUS
          IF (ISAUT(1,ISOUS).NE.0) THEN
            ischm = ischm + 1
            IF (ISAUT(IVAL-1,ISOUS).EQ.2) THEN
              MCHAM1 = ICHAML(ischm)
              DO IJC = 1,N2
                MOCOMP = MCHAM1.NOMCHE(IJC)
                IF (MOCOMP.EQ.'T       ') GOTO 25
              ENDDO
 25           CONTINUE
              MCHAM1.IELVAL(IJC)=ISAUT(IVAL,ISOUS)
            ENDIF
          ENDIF
        ENDDO
      ENDIF
C
      SEGSUP,MTRA2,ISAUT,ICPR

C COMPACTAGE DU CHAMP OBTENU :
      NSCHM = mchelm.ICHAML(/1)
      DO ischm = 1, NSCHM
        MCHAML = mchelm.ICHAML(ischm)
        N2 = mchaml.IELVAL(/1)
        DO ijc = 1, N2
          MELVAL = mchaml.IELVAL(ijc)
          IF (MELVAL .NE. 0) CALL COMRED(MELVAL)
        ENDDO
      ENDDO

      IPCHEL=MCHELM
*  preconditionnement on garde l'operation en memoire
      ith=oothrd
      do iprec=nprcha,2,-1
      iprma(iprec,ith) =iprma(iprec-1,ith)
      iprhoa(iprec,ith)=iprhoa(iprec-1,ith)
      iprmo(iprec,ith) =iprmo(iprec-1,ith)
      iprhom(iprec,ith)=iprhom(iprec-1,ith)
      iprchp(iprec,ith)=iprchp(iprec-1,ith)
      iprhoc(iprec,ith)=iprhoc(iprec-1,ith)
      iprsu(iprec,ith) =iprsu(iprec-1,ith)
      iprcha(iprec,ith)=iprcha(iprec-1,ith)
      iprcnf(iprec,ith)=iprcnf(iprec-1,ith)
      iprchl(iprec,ith)=iprchl(iprec-1,ith)
      enddo
      iprma(1,ith) =ipmail
      iprhoa(1,ith)=ihomai
      iprmo(1,ith) =ipmodl
      iprhom(1,ith)=ihomod
      iprchp(1,ith)=ipchpo
      iprhoc(1,ith)=ihochp
      iprsu(1,ith) =isup
      iprcha(1,ith)=cha
      iprcnf(1,ith)=mcoord
      iprchl(1,ith)=ipchel
**    write(6,*) ' preconditionnement de ',ipchel

      END