C MODSTA SOURCE JK148537 24/10/29 21:15:07 12056 SUBROUTINE MODSTA(IPMOD,IPTABM,ipmod1) C implicit real*8(a-h,o-z) -INC PPARAM -INC CCOPTIO -INC SMMODEL POINTEUR IMODE3.IMODEL -INC SMTABLE -INC SMELEME -INC SMLENTI logical login,lobre,lexmod,dupli2 character*8 charin,charre,tapind,typobj * ipmod1 initialise dans modeli if (ipmod1.gt.0) then call pimodl(ipmod1,ipmod2,iptz,1) mmodel = ipmod2 endif * write(6,*) 'modsta',ipmod,iptabm,mmodel is0 = kmodel(/1) isa = 1 isb = is0 IVOUT = 0 IVALI0 = 0 * n1 = kmodel(/1) isk = n1 segini,mmode2=mmodel call dimen7(iptabm,idimen) n1 = n1 * idimen segadj,mmode2 n21 = n1 * dupliquer modele elementaire do 100 is = 1,is0 imode2 = kmodel(is) dupli2 = .true. ivok = 0 lexmod = .false. do jma=1,imode2.matmod(/2) if(imode2.matmod(jma).eq.'STATIONNAIRE') then nobmod = imode2.ivamod(/1) if (imode2.tymode(nobmod).ne.'IMODEL') then * write(6,*) 'verifier sous-zone ',is,imode2,' pour stationnaire' call erreur(21) return endif lexmod = .true. goto 6 endif enddo c goto 100 6 continue ipt2 = imode2.imamod ityp2 = ipt2.itypel nbn2 = ipt2.num(/1) nbele2 = ipt2.num(/2) IVALIN = IVALI0 10 CONTINUE * tranche suivante IVALIN=IVALIN + 1 XVALIN=REAL(0.D0) LOGIN=.TRUE. IOBIN=0 TAPIND='ENTIER ' CHARIN=' ' TYPOBJ=' ' CALL ACCTAB(IPTABM,TAPIND,IVALIN,XVALIN,CHARIN,LOGIN,IOBIN, . TYPOBJ,IVALRE,XVALRE,CHARRE,LOGRE,IOBRE) c write(6,*)'bsta',ivalin,iobre,typobj,ierr IF (IERR.NE.0) RETURN if (typobj.eq.' '.AND.IVALIN.EQ.1) GOTO 10 if (typobj.ne.'MAILLAGE') then if (ivout.eq.0) then ivout = ivok elseif (ivout.ne.ivok) then c write(6,*) 'duplication non homogène', is call erreur(21) return endif goto 100 endif * traiter les maillages elementaires MELEME = IOBRE segact meleme*nomod NSOU = MELEME.LISOUS(/1) NSOU1 = MAX(1,NSOU) DO 80 IM=1,NSOU1 IF (NSOU.EQ.0) THEN IPT1 =MELEME ELSE IPT1 =MELEME.LISOUS(IM) SEGACT,IPT1 ENDIF ITYP1 =IPT1.ITYPEL NBNN =IPT1.NUM(/1) NBELEM = IPT1.NUM(/2) if (ipt1.eq.ipt2) goto 10 if (ityp2.eq.ityp1.and.nbn2.eq.nbnn.and.nbele2.eq.nbelem) then goto 60 endif 80 CONTINUE * write(6,*) 'la tranche ', ivalin,' n est pas homeomorphe' call erreur(21) return 60 CONTINUE * dupliquer modele elementaire segini,imodel=imode2 ivok = ivok + 1 isk = isk + 1 if (isk.ge.n21) then n1 = n21 + is0 segadj mmode2 n21 = n1 endif mmode2.kmodel(isk) = imodel * segact imodel*mod imamod = ipt1 C ... modif constituant ? nobmod = ivamod(/1) if (lexmod) then * surcharge indice nobmod else mn3 = infmod(/1) nfor = formod(/2) nmat = matmod(/2) nmat = nmat + 1 c write(6,*) 'modsta',imodel,mn3,nfor,nmat,nobmod nobmod = nobmod + 1 segadj imodel matmod(nmat) = 'STATIONNAIRE' tymode(nobmod) = 'IMODEL' endif IF (dupli2) THEN * stationnaire : pointe la sous-zone dupliquee ivamod(nobmod) = imode2 dupli2 = .false. ELSE * ou bien la tranche anterieure (en s epargnant de tester le contenu) ivamod(nobmod) = mmode2.kmodel(isk - 1) ENDIF goto 10 CCCC 100 continue if (IVOUT.gt.0) then c write(6,*) ' ',ivout,' tranches dupliquees stationnaires' else call erreur(21) return endif * fin duplication n1 = isk segadj mmode2 c ipmod = mmode2 jg = 0 segini mlenti,mlent1,mlent2 * reaffecte modeles parallele do 200 is = 1,is0 imode2 = kmodel(is) if (imode2.cmatee.eq.'PARALLEL') then nobmod = imode2.ivamod(/1) nmat = imode2.matmod(/2) if (imode2.matmod(nmat).eq.'STATIONNAIRE') then if (imode2.tymode(nobmod).ne.'IMODEL') then *jk18537 conventionnel * write(6,*) 'sous-zone', is, imode2, ' PARALLEL mal defini' call erreur(21) return endif jg = nobmod else jg = nobmod + 1 endif if (jg.ne.lect(/1)) then segadj mlenti,mlent1,mlent2 endif do jj = 1,jg lect(jj) = 0 mlent1.lect(jj) = 0 enddo do iv=1,nobmod if (imode2.tymode(iv).eq.'IMODEL') lect(iv) = imode2.ivamod(iv) mlent2.lect(iv) = lect(iv) enddo mlent2.lect(jg) = imode2 nobjg = jg * debut de recherche isa = is0 + (is-1)*IVOUT do jt = 1,ivout isk = isa + jt imodel = mmode2.kmodel(isk) if (cmatee.eq.'PARALLEL') then nobmod = ivamod(/1) if (tymode(nobmod).ne.'IMODEL'.or.nobmod.ne.nobjg) then c write(6,*) 'erreur duplication' call erreur(5) return endif if (ivamod(nobmod).ne.mlent2.lect(nobmod)) then c write(6,*) 'erreur de suivi' call erreur(5) return endif mlent2.lect(nobmod) = imodel do iv = 1,nobjg-1 if (tymode(iv).eq.'IMODEL') then if (ivamod(iv).eq.lect(iv)) then if (mlent1.lect(iv).eq.0) then do lu = 1,is0 if (mmode2.kmodel(lu).eq.lect(iv)) then isb = is0 + (lu - 1)*ivout + 1 mlent1.lect(iv) = isb endif enddo endif * isu = mlent1.lect(iv) imode1 = mmode2.kmodel(isu) nobmod = imode1.ivamod(/1) nmat = imode1.matmod(/2) if (imode1.matmod(nmat).ne.'STATIONNAIRE'.OR. & imode1.tymode(nobmod).ne.'IMODEL'.OR. & imode1.ivamod(nobmod).ne.mlent2.lect(iv) ) then * write(6,*) 'erreur 3 duplication',is,isk,isu * write(6,*) imode1.matmod(nmat).ne.'STATIONNAIRE' * write(6,*) imode1.tymode(nobmod).ne.'IMODEL' * write(6,*) imode1.ivamod(nobmod),mlent2.lect(iv) call erreur(21) return endif * petit test if (imode1.imamod.ne.imamod) then c write(6,*) imodel,' erreur affectation parallele ',imode1 call erreur(21) return endif ivamod(iv) = imode1 mlent1.lect(iv) = isu + 1 mlent2.lect(iv) = imode1 else c write(6,*) 'erreur 2 duplication' call erreur(21) return endif endif enddo else c write(6,*) 'mal gere les indices' call erreur(5) return endif enddo endif 200 continue * segsup mlenti,mlent1,mlent2 * condense mmode2 mmodel = mmode2 n1 = kmodel(/1) segini mmode1 n10 = n1 mmode2 = ipmod1 n21 = mmode2.kmodel(/1) isk1 = n21 jtk0 = 0 do 300 is = 1,n21 imode1 = mmode2.kmodel(is) imodu = imode1 mmode1.kmodel(is) = imode1 nmat1 = imode1.matmod(/2) jtk = 0 do 350 jt = n21, n10 imodel = kmodel(jt) if (imodel.eq.0) goto 350 nobmod = ivamod(/1) nmat = matmod(/2) if (matmod(nmat).eq.'STATIONNAIRE') then if (tymode(nobmod).ne.'IMODEL') then c write(6,*) 'erreur 3 duplication' call erreur(21) return endif if (ivamod(nobmod).ne.imodu) goto 350 isk1 = isk1 + 1 jtk = jtk + 1 mmode1.kmodel(isk1) = imodel imodu = imodel kmodel(jt) = 0 endif 350 continue if (jtk0.eq.0) then jtk0 = jtk else if (jtk.ne.jtk0) then c write(6,*) 'erreur 4 duplication' call erreur(21) return endif endif 300 continue n1 = isk1 segadj mmode1 ipmod = mmode1 segsup mmodel c write(6,*) 'modsta-f-',ipmod,n1,iptabm RETURN END