C MSCHE1 SOURCE KICH 21/11/17 21:15:11 11191 SUBROUTINE MSCHE1(IPCHE2,IPCHE3,X1,IKO,IPCHE1,ICLE,IPCHMA,ISOM, & IRET) ***************************************************************** * OPERATEUR MASQ * * ENTREES : * --------- * IPCHE1 :POINTEUR SUR LE PREMIER CHAMELEM * IPCHE2 :POINTEUR SUR UN SECOND CHAMELEM * IPCHE3 :POINTEUR SUR UN TROISIEME CHAMELEM (OPTION "COMP") * X1 :VALEUR MIN OU MAX (OPTION "COMP") * IKO :0 SI IPCHE2 PUIS IPCHE3 * 1 SI X1 PUIS IPCHE2 * -1 SI IPCHE2 PUIS X1 * ICLE :ENTIER CARACTERISANT LE TYPE DE COMPARAISON * ISOM =1 SI ON VEUT LA SOMME * =0 SINON * * SORTIE : * -------- * IPCHMA :- POINTEUR SUR LE CHAMELEM RESULTAT SI ISOM=0 * - SOMME DES 1 ET DES 0 SI OPTION ISOM=1 * IRET =1 OU 0 SUIVANT SUCCES OU PAS * * PASSAGE AUX NOUVEAU CHAMELEM PAR JM CAMPENON LE 01/91 * ***************************************************************** IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) -INC PPARAM -INC CCOPTIO -INC SMCHAML -INC SMLREEL -INC SMCOORD -INC SMELEME -INC SMINTE * CHARACTER*4 MOK CHARACTER*16 CONCH1,CONCH2,CONCH3 CHARACTER*72 TIT1,TIT2,TIT3,TITC PARAMETER (NINF=3) INTEGER INFOS(NINF) * SEGMENT MTRAA INTEGER ITRAA(LX) ENDSEGMENT SEGMENT MTRAA2 INTEGER ITRAA2(LX) ENDSEGMENT * IKOK=IKO IF (IKOK.EQ.0.AND.IPCHE3.LE.0) IKOK=-1 * IRET = 0 * * POUR INFERIEUR ,IDEM SUPERIEUR EN INVERSANT IPCHE1 ET IPCHE2 * IF (ICLE.EQ.4.OR.ICLE.EQ.5) THEN IKKK=IPCHE2 IPCHE2=IPCHE1 IPCHE1=IKKK IF (ICLE.EQ.4) ICLE=2 IF (ICLE.EQ.5) ICLE=1 ENDIF * JPCHE1=IPCHE1 JPCHE2=IPCHE2 JPCHE3=IPCHE3 * * ========================================================== * ON TESTE D'ABORD LA COMPATIBILITE ENTRE LES MCHAML FOURNIS * ========================================================== MCHEL1 = IPCHE1 MCHEL2 = IPCHE2 IF (MCHEL1.IFOCHE.NE.MCHEL2.IFOCHE) THEN CALL ERREUR(103) GOTO 666 ENDIF CALL CALPAQ(IPCHE1,IPCHE2,K,TITC,NUMCHA,iretou) IF (iretou.EQ.0) GOTO 666 * * -> CALPAQ peut avoir permute les pointeurs mais ils sont toujours ACTIFs IPCHE1=JPCHE1 IPCHE2=JPCHE2 * IF (K.NE.1.AND.K.NE.3.AND.K.NE.5) THEN CALL ERREUR(488) GOTO 666 ENDIF MCHEL1 = IPCHE1 MCHEL2 = IPCHE2 TIT1 = MCHEL1.TITCHE TIT2 = MCHEL2.TITCHE IF (K.EQ.5.AND.(TIT1.NE.TIT2) ) THEN CALL ERREUR(21) GOTO 666 ENDIF NSOUS1 = MCHEL1.ICHAML(/1) NSOUS2 = MCHEL2.ICHAML(/1) IF (NSOUS1.NE.NSOUS2) THEN CALL ERREUR(103) GOTO 666 ENDIF * * QUELLE BIJECTION ENTRE LES SOUS PAQUETS DE MCHEL1 ET DE MCHEL2 * LX=NSOUS1 SEGINI MTRAA * DO 110 ISOUS1=1,NSOUS1 IPMAI1=MCHEL1.IMACHE(ISOUS1) CONCH1=MCHEL1.CONCHE(ISOUS1) DO 120 ISOUS2=1,NSOUS2 IPMAI2=MCHEL2.IMACHE(ISOUS2) CONCH2=MCHEL2.CONCHE(ISOUS2) IF (IPMAI1.NE.IPMAI2.OR.CONCH1.NE.CONCH2) GOTO 120 CALL IDENT (IPMAI1,CONCH1,IPCHE1,IPCHE2,INFOS,IRTD) IF (IRTD.EQ.0) GOTO 120 * IMINT1=0 IMINT2=0 IF (MCHEL1.INFCHE(/2).GE.4) IMINT1=MCHEL1.INFCHE(ISOUS1,4) IF (MCHEL2.INFCHE(/2).GE.4) IMINT2=MCHEL2.INFCHE(ISOUS2,4) IF (IMINT1.EQ.IMINT2) GOTO 121 * IMINT1=1 IMINT2=1 IF (MCHEL1.INFCHE(/2).GE.6) IMINT1=MCHEL1.INFCHE(ISOUS1,6) IF (MCHEL2.INFCHE(/2).GE.6) IMINT2=MCHEL2.INFCHE(ISOUS2,6) IF (IMINT1.EQ.0) IMINT1=1 IF (IMINT2.EQ.0) IMINT2=1 IF (IMINT1.EQ.IMINT2) GOTO 121 * SEGSUP MTRAA * * ERREUR PAS DE CORRESPONDANCE 2 A 2 * CALL ERREUR(103) GOTO 666 * 120 CONTINUE * 121 CONTINUE ITRAA(ISOUS1)=ISOUS2 GOTO 110 110 CONTINUE * SI BESOIN ON FAIT LES MEMES TESTS AVEC LE TROISIEME MCHAML * (OPTION "COMP") IF (IKOK.EQ.0) THEN MCHEL3 = IPCHE3 IF (MCHEL1.IFOCHE.NE.MCHEL3.IFOCHE) THEN CALL ERREUR(103) GOTO 666 ENDIF CALL CALPAQ(IPCHE1,IPCHE3,K,TITC,NUMCHA,iretou) IF (iretou.EQ.0) GOTO 666 * * -> CALPAQ peut avoir permute les pointeurs mais ils sont toujours ACTIFs IPCHE1=JPCHE3 IPCHE3=JPCHE3 * IF (K.NE.1.AND.K.NE.3.AND.K.NE.5) THEN CALL ERREUR(488) GOTO 666 ENDIF MCHEL3 = IPCHE3 TIT3 = MCHEL3.TITCHE IF (K.EQ.5.AND.(TIT1.NE.TIT3) ) THEN CALL ERREUR(21) GOTO 666 ENDIF NSOUS3 = MCHEL3.ICHAML(/1) IF (NSOUS1.NE.NSOUS3) THEN CALL ERREUR(103) GOTO 666 ENDIF LX=NSOUS1 SEGINI MTRAA2 DO 150 ISOUS1=1,NSOUS1 IPMAI1=MCHEL1.IMACHE(ISOUS1) CONCH1=MCHEL1.CONCHE(ISOUS1) DO 160 ISOUS3=1,NSOUS3 IPMAI3=MCHEL3.IMACHE(ISOUS3) CONCH3=MCHEL3.CONCHE(ISOUS3) IF (IPMAI1.NE.IPMAI3.OR.CONCH1.NE.CONCH3) GOTO 160 CALL IDENT (IPMAI1,CONCH1,IPCHE1,IPCHE3,INFOS,IRTD) IF (IRTD.EQ.0) GOTO 160 * IMINT1=0 IMINT3=0 IF (MCHEL1.INFCHE(/2).GE.4) IMINT1=MCHEL1.INFCHE(ISOUS1,4) IF (MCHEL3.INFCHE(/2).GE.4) IMINT3=MCHEL3.INFCHE(ISOUS3,4) IF (IMINT1.EQ.IMINT3) GOTO 151 * IMINT1=1 IMINT3=1 IF (MCHEL1.INFCHE(/2).GE.6) IMINT1=MCHEL1.INFCHE(ISOUS1,6) IF (MCHEL3.INFCHE(/2).GE.6) IMINT3=MCHEL3.INFCHE(ISOUS3,6) IF (IMINT1.EQ.0) IMINT1=1 IF (IMINT3.EQ.0) IMINT3=1 IF (IMINT1.EQ.IMINT3) GOTO 151 * SEGSUP MTRAA2 * * ERREUR PAS DE CORRESPONDANCE 2 A 2 * CALL ERREUR(103) GOTO 666 * 160 CONTINUE * 151 CONTINUE ITRAA2(ISOUS1)=ISOUS3 GOTO 150 150 CONTINUE ENDIF * ====================================== * ON FAIT LA COMPARAISON PROPREMENT DITE * ====================================== KSOM=0 NSOUS=NSOUS1 N1=NSOUS N3=MCHEL1.INFCHE(/2) L1=MCHEL1.TITCHE(/1) SEGINI MCHELM IPCHMA=MCHELM IFOCHE=MCHEL1.IFOCHE TITCHE=TIT1 * * BOUCLE SUR LES SOUS PAQUETS DE MCHELM * DO 200 ISOUS=1,NSOUS DO 201 N33=1,N3 INFCHE(ISOUS,N33)=MCHEL1.INFCHE(ISOUS,N33) 201 CONTINUE IMACHE(ISOUS)=MCHEL1.IMACHE(ISOUS) CONCHE(ISOUS)=MCHEL1.CONCHE(ISOUS) * ISOUS2=ITRAA(ISOUS) * MCHAM1=MCHEL1.ICHAML(ISOUS ) MCHAM2=MCHEL2.ICHAML(ISOUS2) IF (IKOK.EQ.0) THEN ISOUS3=ITRAA2(ISOUS) MCHAM3=MCHEL3.ICHAML(ISOUS3) ENDIF * meleme = imache(isous) nnel = num(/2) if (infche(isous,4).eq.0) then nnptel = num(/1) else minte = infche(isous,4) nnptel = qsigau(/1) endif * NCOMP=MCHAM1.IELVAL(/1) N2=NCOMP SEGINI MCHAML ICHAML(ISOUS)=MCHAML DO 300 ICOMP=1,NCOMP CALL PLACE ( MCHAM2.NOMCHE,MCHAM2.IELVAL(/1),IPLAC, & MCHAM1.NOMCHE(ICOMP) ) * IF (IPLAC.EQ.0) THEN MOTERR(1:4)=MCHAM1.NOMCHE(ICOMP) MOTERR(5:8)=TIT1(1:4) CALL ERREUR(77) SEGSUP MCHAML,MCHELM,MTRAA GOTO 666 ENDIF NOMCHE(ICOMP)=MCHAM1.NOMCHE(ICOMP) TYPCHE(ICOMP)=MCHAM1.TYPCHE(ICOMP) * MELVA1=MCHAM1.IELVAL(ICOMP) MELVA2=MCHAM2.IELVAL(IPLAC) * IF (IKOK.EQ.0) THEN CALL PLACE ( MCHAM3.NOMCHE,MCHAM3.IELVAL(/1),IPLAC2, & MCHAM1.NOMCHE(ICOMP) ) * IF (IPLAC2.EQ.0) THEN MOTERR(1:4)=MCHAM1.NOMCHE(ICOMP) MOTERR(5:8)=TIT1(1:4) CALL ERREUR(77) SEGSUP MCHAML,MCHELM,MTRAA GOTO 666 ENDIF * MELVA3=MCHAM3.IELVAL(IPLAC2) ENDIF * IF (MCHAM1.TYPCHE(ICOMP).EQ.'REAL*8') THEN NBPTE1=MELVA1.VELCHE(/1) NEL1 =MELVA1.VELCHE(/2) NBPTE2=MELVA2.VELCHE(/1) NEL2 =MELVA2.VELCHE(/2) NBPGAU=MAX(NBPTE1,NBPTE2) NBELEM=MAX(NEL1,NEL2) IF (IKOK.EQ.0) THEN NBPTE3=MELVA3.VELCHE(/1) NEL3 =MELVA3.VELCHE(/2) NBPGAU=MAX(NBPTE1,NBPTE3) NBELEM=MAX(NEL1,NEL3) ENDIF * N2PTEL=0 N2EL =0 N1PTEL=NBPGAU N1EL =NBELEM * IML=0 ELSE IF (MCHAM1.TYPCHE(ICOMP).EQ.'POINTEURLISTREEL') THEN NBPTE1=MELVA1.IELCHE(/1) NEL1 =MELVA1.IELCHE(/2) NBPTE2=MELVA2.IELCHE(/1) NEL2 =MELVA2.IELCHE(/2) NBPGAU=MAX(NBPTE1,NBPTE2) NBELEM=MAX(NEL1,NEL2) IF (IKOK.EQ.0) THEN NBPTE3=MELVA3.VELCHE(/1) NEL3 =MELVA3.VELCHE(/2) NBPGAU=MAX(NBPTE1,NBPTE3) NBELEM=MAX(NEL1,NEL3) ENDIF * N1PTEL=0 N1EL =0 N2PTEL=NBPGAU N2EL =NBELEM * IML=1 ELSE * * COMPOSANTE NON RECONNUE * MOTERR (1:4)=MCHAM1.NOMCHE(ICOMP) CALL ERREUR (197) SEGSUP MCHAML,MCHELM,MTRAA GOTO 666 ENDIF SEGINI MELVAL IELVAL(ICOMP)=MELVAL * * MOT-CLE "SUPE" OU "INFE" IF (ICLE.EQ.1) THEN DO 331 IGAU=1,NBPGAU IGMN1=MIN(IGAU,NBPTE1) IGMN2=MIN(IGAU,NBPTE2) DO 331 IB=1,NBELEM IBMN1=MIN(IB,NEL1) IBMN2=MIN(IB,NEL2) IF (IML.EQ.0) THEN XTT1 =MELVA1.VELCHE(IGMN1,IBMN1) XTT2 =MELVA2.VELCHE(IGMN2,IBMN2) IF (XTT1.GT.XTT2) THEN VELCHE(IGAU,IB)=1.D0 KSOM=KSOM+1 ENDIF ELSE MLREE1=MELVA1.IELCHE(IGMN1,IBMN1) MLREE2=MELVA2.IELCHE(IGMN2,IBMN2) IPRO1=MLREE1.PROG(/1) IPRO2=MLREE2.PROG(/1) JG=MAX(IPRO1,IPRO2) * SEGINI MLREEL * DO 302 IPROG=1,JG IPMN1=MIN(IPRO1,IPROG) IPMN2=MIN(IPRO2,IPROG) XTT1=MLREE1.PROG(IPMN1) XTT2=MLREE2.PROG(IPMN2) IF (XTT1.GT.XTT2) THEN PROG(IPROG)=1.D0 KSOM=KSOM+1 ENDIF 302 CONTINUE IELCHE(IGAU,IB)=MLREEL ENDIF 331 CONTINUE * * MOT-CLE "EGSU" OU "EGIN" ELSEIF (ICLE.EQ.2) THEN DO 332 IGAU=1,NBPGAU IGMN1=MIN(IGAU,NBPTE1) IGMN2=MIN(IGAU,NBPTE2) DO 332 IB=1,NBELEM IBMN1=MIN(IB,NEL1) IBMN2=MIN(IB,NEL2) IF (IML.EQ.0) THEN XTT1 =MELVA1.VELCHE(IGMN1,IBMN1) XTT2 =MELVA2.VELCHE(IGMN2,IBMN2) IF (XTT1.GE.XTT2) THEN VELCHE(IGAU,IB)=1.D0 KSOM=KSOM+1 ENDIF ELSE MLREE1=MELVA1.IELCHE(IGMN1,IBMN1) MLREE2=MELVA2.IELCHE(IGMN2,IBMN2) IPRO1=MLREE1.PROG(/1) IPRO2=MLREE2.PROG(/1) JG=MAX(IPRO1,IPRO2) * SEGINI MLREEL * DO 303 IPROG=1,JG IPMN1=MIN(IPRO1,IPROG) IPMN2=MIN(IPRO2,IPROG) XTT1=MLREE1.PROG(IPMN1) XTT2=MLREE2.PROG(IPMN2) IF (XTT1.GE.XTT2) THEN PROG(IPROG)=1.D0 KSOM=KSOM+1 ENDIF 303 CONTINUE IELCHE(IGAU,IB)=MLREEL ENDIF 332 CONTINUE * * MOT-CLE "EGAL" ELSEIF (ICLE.EQ.3) THEN DO 333 IGAU=1,NBPGAU IGMN1=MIN(IGAU,NBPTE1) IGMN2=MIN(IGAU,NBPTE2) DO 333 IB=1,NBELEM IBMN1=MIN(IB,NEL1) IBMN2=MIN(IB,NEL2) IF (IML.EQ.0) THEN XTT1 =MELVA1.VELCHE(IGMN1,IBMN1) XTT2 =MELVA2.VELCHE(IGMN2,IBMN2) IF (XTT1.EQ.XTT2) THEN VELCHE(IGAU,IB)=1.D0 KSOM=KSOM+1 ENDIF ELSE MLREE1=MELVA1.IELCHE(IGMN1,IBMN1) MLREE2=MELVA2.IELCHE(IGMN2,IBMN2) IPRO1=MLREE1.PROG(/1) IPRO2=MLREE2.PROG(/1) JG=MAX(IPRO1,IPRO2) * SEGINI MLREEL * DO 304 IPROG=1,JG IPMN1=MIN(IPRO1,IPROG) IPMN2=MIN(IPRO2,IPROG) XTT1=MLREE1.PROG(IPMN1) XTT2=MLREE2.PROG(IPMN2) IF (XTT1.EQ.XTT2) THEN PROG(IPROG)=1.D0 KSOM=KSOM+1 ENDIF 304 CONTINUE IELCHE(IGAU,IB)=MLREEL ENDIF 333 CONTINUE * * MOT-CLE "DIFF" ELSEIF (ICLE.EQ.6) THEN DO 336 IGAU=1,NBPGAU IGMN1=MIN(IGAU,NBPTE1) IGMN2=MIN(IGAU,NBPTE2) DO 336 IB=1,NBELEM IBMN1=MIN(IB,NEL1) IBMN2=MIN(IB,NEL2) IF (IML.EQ.0) THEN XTT1 =MELVA1.VELCHE(IGMN1,IBMN1) XTT2 =MELVA2.VELCHE(IGMN2,IBMN2) IF (XTT1.NE.XTT2) THEN VELCHE(IGAU,IB)=1.D0 KSOM=KSOM+1 ENDIF ELSE MLREE1=MELVA1.IELCHE(IGMN1,IBMN1) MLREE2=MELVA2.IELCHE(IGMN2,IBMN2) IPRO1=MLREE1.PROG(/1) IPRO2=MLREE2.PROG(/1) JG=MAX(IPRO1,IPRO2) * SEGINI MLREEL * DO 305 IPROG=1,JG IPMN1=MIN(IPRO1,IPROG) IPMN2=MIN(IPRO2,IPROG) XTT1=MLREE1.PROG(IPMN1) XTT2=MLREE2.PROG(IPMN2) IF (XTT1.NE.XTT2) THEN PROG(IPROG)=1.D0 KSOM=KSOM+1 ENDIF 305 CONTINUE IELCHE(IGAU,IB)=MLREEL ENDIF 336 CONTINUE * * MOT-CLE "COMP" ELSEIF (ICLE.EQ.7) THEN IF (IKOK.EQ.0) THEN DO 337 IGAU=1,NBPGAU IGMN1=MIN(IGAU,NBPTE1) IGMN2=MIN(IGAU,NBPTE2) IGMN3=MIN(IGAU,NBPTE3) DO 337 IB=1,NBELEM IBMN1=MIN(IB,NEL1) IBMN2=MIN(IB,NEL2) IBMN3=MIN(IB,NEL3) IF (IML.EQ.0) THEN XTT1 =MELVA1.VELCHE(IGMN1,IBMN1) XTT2 =MELVA2.VELCHE(IGMN2,IBMN2) XTT3 =MELVA3.VELCHE(IGMN3,IBMN3) IF (XTT1.GE.XTT2.AND.XTT1.LE.XTT3) THEN VELCHE(IGAU,IB)=1.D0 KSOM=KSOM+1 ENDIF ELSE MLREE1=MELVA1.IELCHE(IGMN1,IBMN1) MLREE2=MELVA2.IELCHE(IGMN2,IBMN2) MLREE3=MELVA3.IELCHE(IGMN3,IBMN3) IPRO1=MLREE1.PROG(/1) IPRO2=MLREE2.PROG(/1) IPRO3=MLREE3.PROG(/1) JG=MAX(IPRO1,IPRO2,IPRO3) * SEGINI MLREEL * DO 306 IPROG=1,JG IPMN1=MIN(IPRO1,IPROG) IPMN2=MIN(IPRO2,IPROG) IPMN3=MIN(IPRO3,IPROG) XTT1=MLREE1.PROG(IPMN1) XTT2=MLREE2.PROG(IPMN2) XTT3=MLREE3.PROG(IPMN3) IF (XTT1.GE.XTT2.AND.XTT1.LE.XTT3) THEN PROG(IPROG)=1.D0 KSOM=KSOM+1 ENDIF 306 CONTINUE IELCHE(IGAU,IB)=MLREEL ENDIF 337 CONTINUE ELSEIF (IKOK.GT.0) THEN DO 338 IGAU=1,NBPGAU IGMN1=MIN(IGAU,NBPTE1) IGMN2=MIN(IGAU,NBPTE2) DO 338 IB=1,NBELEM IBMN1=MIN(IB,NEL1) IBMN2=MIN(IB,NEL2) IF (IML.EQ.0) THEN XTT1 =MELVA1.VELCHE(IGMN1,IBMN1) XTT2 =MELVA2.VELCHE(IGMN2,IBMN2) IF (XTT1.GE.X1.AND.XTT1.LE.XTT2) THEN VELCHE(IGAU,IB)=1.D0 KSOM=KSOM+1 ENDIF ELSE MLREE1=MELVA1.IELCHE(IGMN1,IBMN1) MLREE2=MELVA2.IELCHE(IGMN2,IBMN2) IPRO1=MLREE1.PROG(/1) IPRO2=MLREE2.PROG(/1) JG=MAX(IPRO1,IPRO2) * SEGINI MLREEL * DO 307 IPROG=1,JG IPMN1=MIN(IPRO1,IPROG) IPMN2=MIN(IPRO2,IPROG) XTT1=MLREE1.PROG(IPMN1) XTT2=MLREE2.PROG(IPMN2) IF (XTT1.GE.X1.AND.XTT1.LE.XTT2) THEN PROG(IPROG)=1.D0 KSOM=KSOM+1 ENDIF 307 CONTINUE IELCHE(IGAU,IB)=MLREEL ENDIF 338 CONTINUE ELSE DO 339 IGAU=1,NBPGAU IGMN1=MIN(IGAU,NBPTE1) IGMN2=MIN(IGAU,NBPTE2) DO 339 IB=1,NBELEM IBMN1=MIN(IB,NEL1) IBMN2=MIN(IB,NEL2) IF (IML.EQ.0) THEN XTT1 =MELVA1.VELCHE(IGMN1,IBMN1) XTT2 =MELVA2.VELCHE(IGMN2,IBMN2) IF (XTT1.GE.XTT2.AND.XTT1.LE.X1) THEN VELCHE(IGAU,IB)=1.D0 KSOM=KSOM+1 ENDIF ELSE MLREE1=MELVA1.IELCHE(IGMN1,IBMN1) MLREE2=MELVA2.IELCHE(IGMN2,IBMN2) IPRO1=MLREE1.PROG(/1) IPRO2=MLREE2.PROG(/1) JG=MAX(IPRO1,IPRO2) * SEGINI MLREEL * DO 308 IPROG=1,JG IPMN1=MIN(IPRO1,IPROG) IPMN2=MIN(IPRO2,IPROG) XTT1=MLREE1.PROG(IPMN1) XTT2=MLREE2.PROG(IPMN2) IF (XTT1.GE.XTT2.AND.XTT1.LE.X1) THEN PROG(IPROG)=1.D0 KSOM=KSOM+1 ENDIF 308 CONTINUE IELCHE(IGAU,IB)=MLREEL ENDIF 339 CONTINUE ENDIF ENDIF * cas des champs constants par element ou maillage elementaire if(nbpgau.lt.nnptel) ksom = ksom * nnptel if(nbelem.lt.nnel) ksom = ksom * nnel 300 CONTINUE 200 CONTINUE * * FIN DE LA BOUCLE SUR LES SOUS PAQUETS DE MCHEL1 * DESACTIVATON DES SEGMENTS * SEGSUP MTRAA IF (IKOK.EQ.0) SEGSUP MTRAA2 IF (ISOM.EQ.1) THEN CALL DTCHAM(IPCHMA) IPCHMA=KSOM ENDIF IRET = 1 666 CONTINUE END