C KOMCHA SOURCE CB215821 25/06/30 21:15:03 12305 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 * 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) IF (IERR.NE.0) RETURN 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) RETURN else NSR = 0 NCOSOR = 0 SEGADJ, MPTVAL RETURN endif 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) RETURN 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) RETURN 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) RETURN 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) RETURN 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) RETURN 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) RETURN 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) RETURN ELSE C Données incompatibles ** CALL ERREUR(21) ENDIF ENDIF ENDDO RETURN END