C KOMCHA SOURCE FANDEUR 11/07/19 21:16:13 7039 SUBROUTINE KOMCHA(IPTR,IPMAIL,CONM,IPNOMC,MOTYPE,ICOND,INFOS, & NINFO,IPTVAL) * IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) *--------------------------------------------------------------------* * * * Recherche des valeurs des composantes dans les MELVAL d'un * * CHAMELEM. On distingue les composantes obligatoires des * * composantes facultatives. * * * *--------------------------------------------------------------------* * * * Entrées: * * * * IPTR pointeur sur le MCHAML * * IPMAIL sous zone élémentaire de l'objet MAILLAGE * * pointée par le MODELE * * CONM nom du constituant de la sous-zone * * IPNOMC pointeur sur les listes de composantes * * obligatoires et facultatives (ACTIF E/S) * * MOTYPE pointeur sur un segment definissant les types des * * composantes cherchees (ACTIF E/S) * * Si le segment est vide, on ne fait pas la * * verification sur les types * * ICOND lecture impérative ou non des composantes * * obligatoires ( 1 si oui, 0 sinon ) * * AM 8/12/93 ( on ajoute le cas icond = 2 qui est une lecture * * imperative mais sans test sur le nom de la * * composante si le MCHAML n'a qu'une composante * * et que l'on ne cherche qu'une composante) * * ( utilisé dans MATER et MANU ) * * INFOS les INFOS à comparer à INFCHE * * NINFO leur nombre * * * * SORTIES: * * * * IPTVAL pointeur pointant sur le tableau de pointeur * * associé a tous les MELVAL correspondant à la * * sous zone (ACTIF S) * * = 0 en cas d'ERREUR (et IERR est aussi non nul) * * * *--------------------------------------------------------------------* * * * Remarques * * * * on commence par ne tester l'identité des géométries que sur les * * pointeurs. Sans succès, on teste ensuite sur le contenu des * * maillages. Ainsi, dans le cas où des pointeurs conviennent, * * on s'arrête sans regarder si d'autres maillages conviendraient * * aussi, sans pour autant avoir le bon pointeur. * * * * on ne teste le constituant que s'il y a plusieurs sous-chamelem * * éligibles * * * *--------------------------------------------------------------------* * * * PM : 08/08/2006 * * si lecture facultative seulement et aucune composante lue * * alors renvoie un segment vide (NSR=0,NCOSOR=0) * * * *--------------------------------------------------------------------* -INC CCOPTIO * -INC SMCHAML * SEGMENT NOMID CHARACTER*8 LESOBL(NBROBL),LESFAC(NBRFAC) ENDSEGMENT * SEGMENT NOTYPE CHARACTER*16 TYPE(NBTYPE) ENDSEGMENT * SEGMENT MPTVAL INTEGER IPOS(NSR) ,NSOF(NSR) INTEGER IVAL(NCOSOR) CHARACTER*16 TYVAL(NCOSOR) ENDSEGMENT * LOGICAL LOG * CHARACTER*4 NOHA CHARACTER*(NCONCH) CONM INTEGER INFOS(*) * IF (IIMPI.GT.0) write (IOIMP,*) 'komcha' * NOMID=IPNOMC SEGACT NOMID NBROBL=LESOBL(/2) NBRFAC=LESFAC(/2) * NOTYPE=MOTYPE SEGACT NOTYPE NBTYPE=TYPE(/2) * NSR = 10 NCOSOR = NSR * ( NBROBL + NBRFAC ) SEGINI MPTVAL IPTVAL=MPTVAL * MCHELM=IPTR SEGACT,MCHELM N1 = IMACHE(/1) N3 = INFCHE(/2) NN3 = MIN(N3,NINFO) * * Recherche du ICHAML correspondant à la zone élémentaire * pointée par le modèle * * 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 * * AM 16/03/07 * EN CAS DE CONSTITUANTS TOUS ' ', ON APELLE * TESTMA AVEC LOG = .FALSE. AU LIEU DE .TRUE. * NS = 0 * DO 1 I=1,N1 * ON IDENTIFIE LE ICHAML * * on ne teste l'identité des géométries que sur les pointeurs * on ne teste le constituant que s'il y a plusieurs sous-chamelem éligibles * write (6,*) ' komcha i conm conche',i,conm,conche(i) IF ( IPMAIL.NE.IMACHE(I) .OR. & (INS.NE.1.AND.CONM.NE.CONCHE(I)) ) GO TO 1 * * ON VERIFIE LA COMPATIBILITE DES INFOS * IF (NN3.EQ.0) THEN NS=NS+1 * write (6,*) ' komcha-1 ns i ',ns,i ELSE DO J=1,NN3 * test numéro d'harmonique WRITE(NOHA,FMT='(A4)') INFCHE(I,J) IF (INFOS(J).NE.INFCHE(I,J).AND.(NOHA.NE.'NOHA')) GOTO 1 ENDDO NS=NS+1 * write (6,*) ' komcha-2 ns i j ',ns,i,j ENDIF IF (NS.GT.NSR) THEN NSR = NS+100 SEGADJ MPTVAL ENDIF IPOS(NS) = I 1 CONTINUE * IF (NS.EQ.0) THEN * Aucun pointeur ne correspond * On teste alors les maillages eux-mêmes et leurs points CALL TESTMA(IPTR,IPMAIL,LOG,CONM,IPTRET,IMODI) MCHELM=IPTR SEGDES,MCHELM IF (IERR.NE.0) GOTO 9999 IF (IPTRET.EQ.0) THEN * On n'a pas trouvé, dans un CHAMELEM, de zone géométrique ou * de constituant correspondant à l'objet MODELE CALL ERREUR(472) GOTO 9999 ENDIF * on a trouvé un sous-maillage MCHELM=IPTRET SEGACT,MCHELM N1 = IMACHE(/1) N3 = INFCHE(/2) NN3 = MIN(N3,NINFO) * * ON VERIFIE A NOUVEAU LA COMPATIBILITE DES INFOS * DO 11 I=1,N1 IF (NN3.EQ.0) THEN NS=NS+1 * write (6,*) ' komcha-3 ns i ',ns,i ELSE DO J=1,NN3 * test numéro d'harmonique WRITE(NOHA,FMT='(A4)') INFCHE(I,J) IF (INFOS(J).NE.INFCHE(I,J).AND.(NOHA.NE.'NOHA')) GOTO 11 ENDDO NS=NS+1 * write (6,*) ' komcha-4 ns i j ',ns,i,j ENDIF IF (NS.GT.NSR) THEN NSR = NS+100 SEGADJ MPTVAL ENDIF IPOS(NS) = I 11 CONTINUE ENDIF * * TEST SUR LA NULLITE DE NS AM IF (NS.EQ.0) THEN * la sous zone de maillage %i1 et de constituant %m1:16 a des * informations relatives au champ ( infche) erronnées MOTERR = CONM INTERR(1) = IPMAIL CALL ERREUR(877) GOTO 9999 ENDIF *-- Identification sur les autres critères * NSR = NS NCOSOR = NS * ( NBROBL + NBRFAC ) SEGADJ,MPTVAL * LECAPA=0 IF (ICOND.EQ.2 .AND. NS.EQ.1 .AND. NBROBL.EQ.1 .AND. NBRFAC.EQ.0) & LECAPA=1 * DO JJ=1,NS ITAB=1 * * Activation du ICHAML * MCHAML=ICHAML(IPOS(JJ)) SEGACT,MCHAML IF(NOMCHE(/2).NE.1) LECAPA=0 * * Composantes obligatoires NSOF(JJ)=0 DO IC1=1,nbrobl CALL PLACE(NOMCHE,NOMCHE(/2),IPLAC,LESOBL(IC1-ITAB+1)) IF (IPLAC.EQ.0.AND.LECAPA.EQ.1) IPLAC=1 IF (IPLAC.NE.0) THEN * 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) SEGACT,MELVAL * 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) SEGDES,MCHAML SEGDES,MCHELM GOTO 9999 ENDIF 7 TYVAL(IC1)=TYPCHE(IPLAC) * SEGDES,MELVAL ENDIF ENDDO * * 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) SEGACT,MELVAL * 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) SEGDES,MCHAML SEGDES,MCHELM GOTO 9999 ENDIF 8 TYVAL(IC2)=TYPCHE(IPLAC) NBOFAC=NBOFAC+1 ** SEGDES,MELVAL ENDIF ENDDO *PM si lecture facultative seulement et aucune composante lue *PM alors renvoie un segment vide (NS=0,NCOSOU=0) IF (NBROBL.EQ.0 .AND. NBRFAC.GT.0) THEN IF (NS.EQ.0 .AND. NBOFAC.EQ.0) THEN NSR = 0 NCOSOR = 0 SEGADJ, MPTVAL ENDIF ENDIF *PM ITAB n'est plus utilisé par la suite. *PM ITAB=ITAB+NBRFAC * ** SEGDES,MCHAML ENDDO * verification que les composantes obligatoires sont toutes presentes DO IC1=1,NBROBL 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 * Données incompatibles CALL ERREUR(21) ENDIF GOTO 9999 ENDIF ENDDO * 9999 CONTINUE ** SEGDES,MCHELM ** SEGDES,NOMID,NOTYPE IF (IERR.NE.0) THEN CALL DTMVAL(IPTVAL,1) IPTVAL = 0 ENDIF * RETURN END