C MENAG4 SOURCE OF166741 25/10/03 21:15:03 12350 C SUPPRIMER LES SEGMENTS INDESIRABLES C SUBROUTINE MENAG4(ISLIS) IMPLICIT INTEGER(I-N) -INC PPARAM -INC CCPRECO C==DEB= FORMULATION HHO == Includes specifiques ======================== -INC CCHHOPA -INC CCHHOPR C==FIN= FORMULATION HHO ================================================ SEGMENT ISLIS(NP) SEGMENT ISEG(0) LOGICAL OOOVP1 IPREC=0 DO 10 I=1,ISLIS(/1) ISEG=ISLIS(I) IF (ISEG.EQ.ISLIS) GOTO 10 IF (ISEG.EQ.IPREC) GOTO 10 IPREC=ISEG SEGSUP,ISEG 10 CONTINUE SEGSUP,ISLIS C Vidange des queues de DESACTIVATION et SUPPRESSION (action faite par lots en temps normal) C ATTENTION : On n'est pas protege par le GLOBAL LOCK, seulement par le LOCK du menage call ooodeq(0) call ooosuq(0) C Verification dans le CCPRECO pour le REDU : On retire les OBJETS que le menage a supprime DO 144 ITH1 = 1, NBASMA+1 ITAILL = NBPRRE(ith1) IF (ITAILL .EQ. 0) GOTO 144 ICOUR = 0 DO 145 IPRECO = 1, ITAILL IMO = PRECMO(IPRECO,ITH1) IF (IMO .EQ. 0) GOTO 145 ICH1 = PRECM1(IPRECO,ITH1) ICH2 = PRECM2(IPRECO,ITH1) C Verification VALIDITE POINTEUR IF(.NOT. (OOOVP1(IMO).AND.OOOVP1(ICH1).AND.OOOVP1(ICH2)))THEN PRECMO(IPRECO,ith1) = 0 PRECM1(IPRECO,ith1) = 0 PRECM2(IPRECO,ith1) = 0 PRECM3(IPRECO,ith1) = 0 PRECM4(IPRECO,ith1) = 0 PRECM5(IPRECO,ith1) = 0 PRECM6(IPRECO,ith1) = 0 ELSE C Le CCPRECO pour le REDU est retasse ICOUR = ICOUR + 1 PRECMO(ICOUR,ith1) = PRECMO(IPRECO,ith1) PRECM1(ICOUR,ith1) = PRECM1(IPRECO,ith1) PRECM2(ICOUR,ith1) = PRECM2(IPRECO,ith1) PRECM3(ICOUR,ith1) = PRECM3(IPRECO,ith1) PRECM4(ICOUR,ith1) = PRECM4(IPRECO,ith1) PRECM5(ICOUR,ith1) = PRECM5(IPRECO,ith1) PRECM6(ICOUR,ith1) = PRECM6(IPRECO,ith1) ENDIF 145 CONTINUE NBPRRE(ith1) = ICOUR 144 CONTINUE C Verification dans le CCPRECO pour les MMODEL etendus (modete) : On supprime ceux que le menage veut supprimer DO 151 ITH1 = 1, NBASMA+1 ITAILL = NBMOMO(ith1) IF (ITAILL .EQ. 0) GOTO 151 ICOUR = 0 DO 152 IPRECO = 1, ITAILL IMO1 = PMOMO1(IPRECO,ITH1) IMO2 = PMOMO2(IPRECO,ITH1) IF (IMO1 .EQ. 0) GOTO 152 C Verification VALIDITE POINTEUR IF(.NOT. (OOOVP1(IMO1).AND.OOOVP1(IMO2)))THEN PMOMO1(IPRECO,ith1) = 0 PMOMO2(IPRECO,ith1) = 0 ELSE C Le CCPRECO pour le REDU est retasse ICOUR = ICOUR + 1 PMOMO1(ICOUR,ith1) = PMOMO1(IPRECO,ith1) PMOMO2(ICOUR,ith1) = PMOMO2(IPRECO,ith1) ENDIF 152 CONTINUE NBMOMO(ith1) = ICOUR 151 CONTINUE C Rebelote pour le preconditionnement de chame1 do 170 ith=0,nbasma do 171 iprec=nprcha,1,-1 ich=iprchl(iprec,ith) if (.not.ooovp1(ich)) then do 172 ipr=iprec,nprcha-1 iprma(ipr,ith) =iprma(ipr+1,ith) iprhoa(ipr,ith)=iprhoa(ipr+1,ith) iprmo(ipr,ith) =iprmo(ipr+1,ith) iprhom(ipr,ith)=iprhom(ipr+1,ith) iprchp(ipr,ith)=iprchp(ipr+1,ith) iprhoc(ipr,ith)=iprhoc(ipr+1,ith) iprsu(ipr,ith) =iprsu(ipr+1,ith) iprcha(ipr,ith)=iprcha(ipr+1,ith) iprcnf(ipr,ith)=iprcnf(ipr+1,ith) iprchl(ipr,ith)=iprchl(ipr+1,ith) 172 continue iprchp(nprcha,ith) =0 endif 171 continue 170 continue C PRECOnditionnement "CMODPG" des MODELEs (pimodl.eso) : DO ith1 = 1, NBASMA+1 ITAILL = NBMODP(ith1) IF (ITAILL .GT. 0) THEN icour = 0 DO ipreco = 1, ITAILL IMO1 = PMODPE(ipreco,ith1) IF (IMO1 .GT. 0) THEN C Verification VALIDITE POINTEUR IMA2 = PMADPS(ipreco,ith1) IF (.NOT. (OOOVP1(IMO1).AND.OOOVP1(IMA2))) THEN PMODPE(ipreco,ith1) = 0 PMODPH(ipreco,ith1) = 0 PMODPS(ipreco,ith1) = 0 PMADPS(ipreco,ith1) = 0 ELSE C Le PREConditionnement CMODPG est retasse icour = icour + 1 PMODPE(icour,ith1) = PMODPE(ipreco,ith1) PMODPH(icour,ith1) = PMODPH(ipreco,ith1) PMODPS(icour,ith1) = PMODPS(ipreco,ith1) PMADPS(icour,ith1) = PMADPS(ipreco,ith1) ENDIF ENDIF ENDDO NBMOCV(ith1) = icour ENDIF ENDDO C PRECOnditionnement "CMOCNV" des MODELEs de CONVECTION (selmod.eso) : DO ith1 = 1, NBASMA+1 ITAILL = NBMOCV(ith1) IF (ITAILL .GT. 0) THEN icour = 0 DO ipreco = 1, ITAILL IMO1 = PMOCVE(ipreco,ith1) IF (IMO1 .GT. 0) THEN C Verification VALIDITE POINTEUR IMO2 = PMOCVS(ipreco,ith1) IF (.NOT. (OOOVP1(IMO1).AND.OOOVP1(IMO2))) THEN PMOCVE(ipreco,ith1) = 0 PMOCVH(ipreco,ith1) = 0 PMOCVS(ipreco,ith1) = 0 ELSE C Le PREConditionnement CMOCNV est retasse icour = icour + 1 PMOCVE(icour,ith1) = PMOCVE(ipreco,ith1) PMOCVH(icour,ith1) = PMOCVH(ipreco,ith1) PMOCVS(icour,ith1) = PMOCVS(ipreco,ith1) ENDIF ENDIF ENDDO NBMOCV(ith1) = icour ENDIF ENDDO C PRECOnditionnement "CLOIEX" des LOIs (selloi.eso) : ITAILL = LOITAB(0) IF (ITAILL .GT. 0) THEN icour = 0 DO ipreco = 1, ITAILL IMO1 = LOITAB(ipreco) IF (IMO1 .GT. 0) THEN C Verification VALIDITE POINTEUR TABLE IMO2 = LOIPRE(ipreco) IF (.NOT. (OOOVP1(IMO1).AND.OOOVP1(IMO2))) THEN LOITAB(ipreco) = 0 LOIPRE(ipreco) = 0 ELSE C Le PREConditionnement CLOIEX est retasse icour = icour + 1 LOITAB(icour) = LOITAB(ipreco) LOIPRE(icour) = LOIPRE(ipreco) ENDIF ENDIF ENDDO LOITAB(0) = icour ENDIF C==DEB= FORMULATION HHO == Traitements specifiques ==================== C Verification si le menage veut supprimer les maillages HHO IF (NUFHHO .GT. 0) THEN c-dbg IF (MSQHHO .GT. 0) THEN IF ( OOOVP1(MSQHHO) .AND. OOOVP1(MCEHHO) .AND. & OOOVP1(MPFHHO) .AND. OOOVP1(MPCHHO) ) THEN c-dbg write(6,*) 'MENAG4 - HHO -> OK Pointeurs Maillages conserves' ELSE write(6,*) 'MENAG4 - HHO -> PB Pointeurs Maillages detruits' END IF END IF C==FIN= FORMULATION HHO ================================================ c RETURN END