Sources Esope | Cast3M

komcha
C KOMCHA    SOURCE    OF166741  25/02/21    21:17:46     12166          
      SUBROUTINE KOMCHA(IPTR,IPMAIL,CONM,IPNOMC,MOTYPE,ICOND,INFOS,
     &                  NINFO,IPTVAL)
 
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
C--------------------------------------------------------------------*
C                                                                    *
C     Recherche des valeurs des composantes dans les MELVAL d'un     *
C     CHAMELEM. On distingue les composantes obligatoires des        *
C     composantes facultatives.                                      *
C                                                                    *
C--------------------------------------------------------------------*
C                                                                    *
C     Entrées:                                                       *
C                                                                    *
C        IPTR      pointeur sur le MCHAML                            *
C        IPMAIL    sous zone élémentaire de l'objet MAILLAGE         *
C                  pointée par le MODELE                             *
C        CONM      nom du constituant de la sous-zone                *
C        IPNOMC    pointeur sur les listes de composantes            *
C                  obligatoires et facultatives          (ACTIF E/S) *
C        MOTYPE    pointeur sur un segment definissant les types des *
C                  composantes cherchees                 (ACTIF E/S) *
C                  Si le segment est vide, on ne fait pas la         *
C                  verification sur les types                        *
C        ICOND     lecture impérative ou non des composantes         *
C                  obligatoires ( 1 si oui, 0 sinon )                *
C   AM 8/12/93     ( on ajoute le cas icond = 2 qui est une lecture  *
C                    imperative mais sans test sur le nom de la      *
C                    composante si le MCHAML n'a qu'une composante   *
C                    et que l'on ne cherche qu'une composante)       *
C                  ( utilisé dans MATER et MANU )                    *
C        INFOS     les INFOS à comparer à INFCHE                     *
C        NINFO     leur nombre                                       *
C                                                                    *
C     SORTIES:                                                       *
C                                                                    *
C        IPTVAL    pointeur pointant sur le tableau de pointeur      *
C                  associé a tous les MELVAL correspondant à la      *
C                  sous zone                             (ACTIF S)   *
C                  = 0 en cas d'ERREUR (et IERR est aussi non nul)   *
C                                                                    *
C--------------------------------------------------------------------*
C                                                                    *
C  Remarques                                                         *
C                                                                    *
C  on commence par ne tester l'identité des géométries que sur les   *
C     pointeurs. Sans succès, on teste ensuite sur le contenu des    *
C     maillages. Ainsi, dans le cas où des pointeurs conviennent,    *
C     on s'arrête sans regarder si d'autres maillages conviendraient *
C     aussi, sans pour autant avoir le bon pointeur.                 *
C                                                                    *
C  on ne teste le constituant que s'il y a plusieurs sous-chamelem   *
C     éligibles                                                      *
C                                                                    *
C--------------------------------------------------------------------*
C                                                                    *
C  PM : 08/08/2006                                                   *
C      si lecture facultative seulement et aucune composante lue     *
C      alors renvoie un segment vide (NSR=0,NCOSOR=0)                *
C                                                                    *
C--------------------------------------------------------------------*
 
-INC PPARAM
-INC CCOPTIO
 
-INC SMCHAML
 
-INC TMPTVAL
 
      SEGMENT NOMID
        CHARACTER*8 LESOBL(NBROBL),LESFAC(NBRFAC)
      ENDSEGMENT
 
      SEGMENT NOTYPE
        CHARACTER*16 TYPE(NBTYPE)
      ENDSEGMENT
 
      LOGICAL LOG
      CHARACTER*4 NOHA
      INTEGER*4 IHA
      EQUIVALENCE(NOHA,IHA)
      DATA NOHA/'NOHA'/
      CHARACTER*(NCONCH) CONM
      INTEGER INFOS(*)
 
      IF (IIMPI.GT.0) write (IOIMP,*) 'komcha'
 
      NOMID=IPNOMC
      NBROBL=LESOBL(/2)
      NBRFAC=LESFAC(/2)
 
      NOTYPE=MOTYPE
      NBTYPE=TYPE(/2)
 
      MCHELM=IPTR
 
      N1  = IMACHE(/1)
      N3  = INFCHE(/2)
      NN3 = MIN(N3,NINFO)
 
      NSR    = N1
** on ne se sert pas de ncosor avant le segadj final
**    NCOSOR = NSR * ( NBROBL + NBRFAC )
      NCOSOR = 0
      SEGINI MPTVAL
      IPTVAL=MPTVAL
C
C     Recherche du ICHAML correspondant à la zone élémentaire
C     pointée par le modèle
C
C     Nombre de sous-zones du chamelem éligibles
      INS=0
      LOG = .FALSE.
      DO I=1,N1
         IF (IPMAIL.EQ.IMACHE(I)) INS=INS+1
         IF (CONCHE(I).NE.'                ') LOG = .TRUE.
      ENDDO
C
C  AM  16/03/07
C      EN CAS DE CONSTITUANTS TOUS '   ', ON APELLE
C      TESTMA AVEC LOG = .FALSE. AU LIEU DE .TRUE.
C
      NS  = 0
C
      DO 1 I=1,N1
C        ON IDENTIFIE LE ICHAML
C
C        on ne teste l'identité des géométries que sur les pointeurs
C           write (6,*) ' komcha i conm conche',i,conm,conche(i)
         IF ( IPMAIL.NE.IMACHE(I)              .OR.
     &       (INS.GE.1.AND.CONM.NE.CONCHE(I)) ) GOTO 1
cjk148537     &       (INS.NE.1.AND.CONM.NE.CONCHE(I)) ) GOTO 1
C
C        ON VERIFIE LA COMPATIBILITE DES INFOS
C
         DO J=1,NN3
C          test numéro d'harmonique
           IF(INFOS(J).NE.INFCHE(I,J).AND.(IHA.NE.INFCHE(I,J))) GOTO 1
         ENDDO
         NS=NS+1
         IF (NS.GT.NSR) THEN
**        write(6,*) ' extension 1 ',ns,nsr
           NSR = NS*2
           SEGADJ MPTVAL
         ENDIF
         IPOS(NS) = I
  1   CONTINUE
C
      IF (NS.EQ.0) THEN
C        Aucun pointeur ne correspond
C        On teste alors les maillages eux-mêmes et leurs points
         CALL TESTMA(IPTR,IPMAIL,LOG,CONM,IPTRET,IMODI)
 
         MCHELM=IPTR
 
         IF (IERR.NE.0) GOTO 9999
         IF (IPTRET.EQ.0) THEN
           if (icond.gt.0) then
C           On n'a pas trouvé, dans un CHAMELEM, de zone géométrique ou
C           de constituant correspondant à l'objet MODELE
            CALL ERREUR(472)
           else
               NSR    = 0
               NCOSOR = 0
               SEGADJ, MPTVAL
           endif
            GOTO 9999
         ENDIF
 
C        on a trouvé un sous-maillage
         MCHELM=IPTRET
         N1  = IMACHE(/1)
         N3  = INFCHE(/2)
         NN3 = MIN(N3,NINFO)
C
C        ON VERIFIE A NOUVEAU LA COMPATIBILITE DES INFOS
C
         DO 11 I=1,N1
           IF (NN3.EQ.0) THEN
             NS=NS+1
C             write (6,*) ' komcha-3 ns i ',ns,i
           ELSE
             DO J=1,NN3
C              test numéro d'harmonique
         IF (INFOS(J).NE.INFCHE(I,J).AND.(IHA.NE.INFCHE(I,J))) GOTO 11
             ENDDO
             NS=NS+1
C             write (6,*) ' komcha-4 ns i j ',ns,i,j
           ENDIF
           IF (NS.GT.NSR) THEN
             NSR = NS*2
**        write(6,*) ' extension 2 ',ns,nsr
             SEGADJ MPTVAL
           ENDIF
           IPOS(NS) = I
  11     CONTINUE
      ENDIF
C
C     TEST SUR LA NULLITE DE NS    AM
      IF (NS.EQ.0) THEN
C        la sous zone de maillage %i1 et de constituant %m1:16 a des
C        informations relatives au champ ( infche) erronnées
         MOTERR = CONM
         INTERR(1) = IPMAIL
         CALL ERREUR(877)
         GOTO 9999
      ENDIF
 
C--   Identification sur les autres critères
      IF(NSR.NE.NS .OR. NCOSOR.NE.NS*(NBROBL+NBRFAC))THEN
        NSR   = NS
        NCOSOR= NS * ( NBROBL + NBRFAC )
**      write(6,*) 'komcha ipos nsr ',ipos(/1),nsr
        SEGADJ,MPTVAL
      ENDIF
C
      LECAPA=0
      IF (ICOND.EQ.2 .AND. NS.EQ.1 .AND. NBROBL.EQ.1 .AND. NBRFAC.EQ.0)
     &    LECAPA=1
C
      DO JJ=1,NS
        ITAB=1
C
C        Activation du ICHAML
C
         MCHAML=ICHAML(IPOS(JJ))
         IF(NOMCHE(/2).NE.1) LECAPA=0
C
C        Composantes obligatoires
         NSOF(JJ)=0
         DO IC1=1,nbrobl
            CALL PLACE(NOMCHE,NOMCHE(/2),IPLAC,LESOBL(IC1-ITAB+1))
C            DO III=1,NOMCHE(/2)
C              PRINT *,'KOMCHA_a:',IC1,':',LESOBL(IC1-ITAB+1),':',
C     &                            III,':',NOMCHE(III),':',IPLAC
C            ENDDO
C            PRINT *,' '
            IF (IPLAC.EQ.0.AND.LECAPA.EQ.1) IPLAC=1
            IF (IPLAC.NE.0) THEN
C     une seule zone autorisee     PV
               if (ival(ic1).ne.0) then
                interr(1)=ipmail
                moterr=conm
                call erreur(769)
                GOTO 9999
               endif
               NSOF(JJ)=NSOF(JJ)+1
               IVAL(IC1)=IELVAL(IPLAC)
               MELVAL=IELVAL(IPLAC)
C              Vérification du type si donné
               IF (NBTYPE.EQ.0) GO TO 7
               ICMN=MIN(IC1,NBTYPE)
               IF (TYPE(ICMN).NE.TYPCHE(IPLAC)
     $             .AND.TYPE(ICMN).NE.'                ') THEN
                  MOTERR(1:16)  = TYPCHE(IPLAC)
                  MOTERR(17:24) = LESOBL(IC1-ITAB+1)
                  MOTERR(25:40) = TITCHE
                  CALL ERREUR(552)
                  GOTO 9999
               ENDIF
 7             TYVAL(IC1)=TYPCHE(IPLAC)
            ENDIF
         ENDDO
C
C        Composantes facultatives
         NBOFAC=0
         ITAB=ITAB+NBROBL
         DO IC2=ITAB,NBRFAC+ITAB-1
            IVAL(IC2)=0
            CALL PLACE(NOMCHE,NOMCHE(/2),IPLAC,LESFAC(IC2-ITAB+1))
            IF (IPLAC.NE.0) THEN
               if (ival(ic2).ne.0) then
                 interr(1)=ipmail
                 moterr=conm
                 call erreur(769)
                 GOTO 9999
               ENDIF
               NSOF(JJ)=NSOF(JJ)+1
               IVAL(IC2)=IELVAL(IPLAC)
               MELVAL=IELVAL(IPLAC)
*  verif iplac pas deja rencontre: lesfac en double
               do ic3=itab,ic2-1
                if(lesfac(ic2-itab+1).eq.lesfac(ic3-itab+1)) then
                  write(6,*) 'ic2 ic3 melval ielval',ic2,ic3,
     >            melval,ielval(ic3)
                  moterr(1:16)=lesfac(ic2-itab+1)
                  call erreur(1144)
                  goto 9999
                endif
               enddo
C              Vérification du type si donné
               IF(NBTYPE.EQ.0) GO TO 8
               ICMN=MIN(IC2,NBTYPE)
               IF (TYPE(ICMN).NE.TYPCHE(IPLAC)
     $             .AND.TYPE(ICMN).NE.'                ') THEN
                  MOTERR(1:16)=TYPCHE(IPLAC)
                  MOTERR(17:24)=LESFAC(IC2-ITAB+1)
                  MOTERR(25:40)=TITCHE
                  CALL ERREUR(552)
                  GOTO 9999
               ENDIF
 8             TYVAL(IC2)=TYPCHE(IPLAC)
               NBOFAC=NBOFAC+1
            ENDIF
         ENDDO
 
CPM      si lecture facultative seulement et aucune composante lue
CPM      alors renvoie un segment vide (NS=0,NCOSOU=0)
         IF (NBROBL.EQ.0 .AND. NBRFAC.GT.0) THEN
*            write(6,*) 'komcxha',ns,nbofac
            IF (NS.EQ.0 .AND. NBOFAC.EQ.0) THEN
               NSR    = 0
               NCOSOR = 0
               SEGADJ, MPTVAL
            ENDIF
c            IF (NBOFAC.EQ.0) THEN
c              ncosor = 0
c              segadj,mptval
c            ENDIF
         ENDIF
 
CPM      ITAB n'est plus utilisé par la suite.
CPM         ITAB=ITAB+NBRFAC
C
      ENDDO
C  verification que les composantes obligatoires sont toutes presentes
         DO IC1=1,NBROBL
c           write(6,*) 'kx4', lesobl(ic1),ival(ic1)
           IF (ival(ic1).eq.0) then
             IF (ICOND.EQ.1 .OR. ICOND.EQ.2) THEN
               MOTERR(1:8) =LESOBL(IC1)
               MOTERR(9:16)=TITCHE
               CALL ERREUR(77)
             ELSE
C                Données incompatibles
**             CALL ERREUR(21)
             ENDIF
             GOTO 9999
           ENDIF
         ENDDO
C
9999  CONTINUE
      IF (IERR.NE.0) THEN
        CALL DTMVAL(IPTVAL,1)
        IPTVAL = 0
      ENDIF
 
c      RETURN
      END