C PYRA1 SOURCE JC220346 16/11/29 21:15:30 9221 C---------------------------------------------------------------------| C | SUBROUTINE PYRA1(II,JJ,IF1,IF2,IGAGNE,IBOUT) C | C CETTE SUBROUTINE TENTE DE CREER UNE PYRAMIDE A PARTIR | C DU TRIANGLE IF1 ET DU QUADRANGLE IF2. | C - IGAGNE=1 EN CAS DE SUCCES | C - IGAGNE=0 EN CAS D'ECHEC | C | C---------------------------------------------------------------------| C IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) -INC TDEMAIT -INC PPARAM -INC CCOPTIO LOGICAL REPONS,FACET,SOLPYR,SOLTET,DIAGO,IN2,VERDIV,IN C * WRITE(6,1000) 1000 FORMAT(' ----->>> PYRA1 <<<-----') C * on se refuse a mailler une pyramide trop ouverte * if (TETA(IF1,IF2,II,JJ).lt.-100) goto 155 nptini=nptmax nfcini=nfcmax ICTF=0 ICTV=0 N3=0 N4=0 N5=0 ipin = 0 * write (6,*) 'entree dans pyra1 ii jj if1 if2 ',ii,jj,if1,if2 * write (6,*) ' liste des facettes ' * DO 443 I=1,NFCMAX * IF (IFAT(I).EQ.1) GOTO 443 * WRITE (6,*) I,NFC(1,I),NFC(2,I),NFC(3,I),NFC(4,I) *443 CONTINUE C C RECHERCHE D'UNE 3EME FACETTE IF3 C -------------------------------- IP1=IPRED(IF1,II) JP1=ISUCC(IF2,II) JP2=IPRED(IF2,JJ) * if (TETA(IF1,IF2,II,JJ).lt.-100) goto 250 C IF3=IFACE3(IP1,II,JP1) C IF (IF3.NE.0) THEN * si if3 dans le mauvais sens rien a faire if (isucc(if3,ii).ne.ip1) then IF (IVERB.EQ.1) write (6,*) ' pyra1 face a l''envers if3 ' return endif IF (NFC(4,IF3).NE.0) THEN CALL prism1(ii,jp1,IF2,IF3,IGAGNE) RETURN ENDIF * WRITE(6,1010)IF3 1010 FORMAT(' ** IF3=',I4) N3=IF3 ENDIF C C C RECHERCHE D'UNE 4EME FACETTE IF4 C -------------------------------- C IF4=IFACE3(JJ,IP1,JP2) C IF (IF4.NE.0) THEN * si if4 dans le mauvais sens rien a faire if (isucc(if4,jj).ne.jp2) then IF (IVERB.EQ.1) write (6,*) ' pyra1 face a l''envers if4 ' return endif IF (NFC(4,IF4).NE.0) THEN CALL prism1(jp2,jj,IF2,IF4,IGAGNE) RETURN ENDIF * WRITE(6,1020)IF4 1020 FORMAT(' ** IF4=',I4) N4=IF4 ENDIF C C C RECHERCHE D'UNE 5EME FACETTE IF5 C -------------------------------- C IF5=IFACE3(JP1,JP2,IP1) C IF (IF5.NE.0) THEN * si if5 dans le mauvais sens rien a faire if (isucc(if5,jp2).ne.jp1) then IF (IVERB.EQ.1) write (6,*) ' pyra1 face a l''envers if5 ' return endif IF (NFC(4,IF5).NE.0) GOTO 9000 * WRITE(6,1030)IF5 1030 FORMAT(' ** IF5=',I4) N5=1 ENDIF C * TEST LONGUEUR IP1 JP1 ET IP1 JP2 IF (N3.EQ.0.AND.N5.EQ.0) THEN DNORM=(XYZ(1,IP1)-XYZ(1,JP1))**2 # +(XYZ(2,IP1)-XYZ(2,JP1))**2 # +(XYZ(3,IP1)-XYZ(3,JP1))**2 DTEST= tetrl*XYZ(4,IP1)*XYZ(4,JP1) IF (DNORM.GT.DTEST) GOTO 250 ENDIF IF (N4.EQ.0.AND.N5.EQ.0) THEN DNORM=(XYZ(1,IP1)-XYZ(1,JP2))**2 # +(XYZ(2,IP1)-XYZ(2,JP2))**2 # +(XYZ(3,IP1)-XYZ(3,JP2))**2 DTEST= tetrl*XYZ(4,IP1)*XYZ(4,JP2) IF (DNORM.GT.DTEST) GOTO 260 ENDIF IF (IF3.EQ.0.AND.IF5.EQ.0) THEN IF (DIAGO(IP1,JP1,diacri)) GOTO 9000 ENDIF IF (IF4.EQ.0.AND.IF5.EQ.0) THEN IF (DIAGO(IP1,JP2,diacri)) GOTO 9000 ENDIF C IF (IF3.EQ.0) THEN C C CREATION DE LA FACETTE IF3 C -------------------------- NFCMAX=NFCMAX+1 IF3=NFCMAX ICTF=ICTF+1 C NFC(1,IF3)=II NFC(2,IF3)=JP1 NFC(3,IF3)=IP1 NFC(4,IF3)=0 C ENDIF C IF (IF4.EQ.0) THEN C C CREATION DE LA FACETTE IF4 C -------------------------- NFCMAX=NFCMAX+1 IF4=NFCMAX ICTF=ICTF+1 C NFC(1,IF4)=JJ NFC(2,IF4)=IP1 NFC(3,IF4)=JP2 NFC(4,IF4)=0 C ENDIF C IF (IF5.EQ.0) THEN C C CREATION DE LA FACETTE IF5 C -------------------------- NFCMAX=NFCMAX+1 IF5=NFCMAX ICTF=ICTF+1 C NFC(1,IF5)=JP1 NFC(2,IF5)=JP2 NFC(3,IF5)=IP1 NFC(4,IF5)=0 C ENDIF C C C ON METS A JOUR LES FACETTES C --------------------------- CALL REPSUB(IF1) CALL REPSUB(IF2) CALL REPSUB(IF3) CALL REPSUB(IF4) CALL REPSUB(IF5) C C LE VOLUME CREE EST-IL VALIDE ? C ------------------------------ IF (N3.EQ.0) THEN IF (.NOT.FACET(IF3)) GOTO 190 ENDIF IF (N4.EQ.0) THEN IF (.NOT.FACET(IF4)) GOTO 190 ENDIF IF (N5.EQ.0) THEN IF (.NOT.FACET(IF5)) GOTO 190 ENDIF IF (.NOT.SOLPYR(IF2,IF1,IF3,IF4,IF5)) GOTO 190 * test des points milieux if (n3.eq.0.and.n5.eq.0) then DO 242 I=1,4 XYZ(I,NPTMAX+1)=(XYZ(4,JP1)*XYZ(I,IP1)+XYZ(4,IP1)*XYZ(I,JP1))/ # (XYZ(4,JP1)+XYZ(4,IP1)) 242 CONTINUE XYZ(4,NPTMAX+1)=SQRT(XYZ(4,IP1)*XYZ(4,JP1)) CALL DIST(nptmax+1,nptaux,GL,IOK,II,JJ,IP1,JP1,JP2,0,0,0,0,0) IF (IOK.EQ.0) then IF (IVERB.EQ.1) write (6,*) ' pyra1 DIST-1 echoue' goto 190 endif IF (gl.lt.xyz(4,nptmax+1)/4) then IF (IVERB.EQ.1) write (6,*) ' pyra1 DIST-1-GL echoue' goto 190 endif endif if (n4.eq.0.and.n5.eq.0) then DO 243 I=1,4 XYZ(I,NPTMAX+1)=(XYZ(4,JP2)*XYZ(I,IP1)+XYZ(4,IP1)*XYZ(I,JP2))/ # (XYZ(4,JP2)+XYZ(4,IP1)) 243 CONTINUE XYZ(4,NPTMAX+1)=SQRT(XYZ(4,IP1)*XYZ(4,JP2)) CALL DIST(nptmax+1,nptaux,GL,IOK,II,JJ,IP1,JP1,JP2,0,0,0,0,0) IF (IOK.EQ.0) then IF (IVERB.EQ.1) write (6,*) ' pyra1 DIST-2 echoue' goto 190 endif IF (gl.lt.xyz(4,nptmax+1)/4) then IF (IVERB.EQ.1) write (6,*) ' pyra1 DIST-2-GL echoue' goto 190 endif endif * C C LE VOLUME CREE EST VALIDE C ------------------------- C MEMORISATION DU VOLUME OBTENU C ----------------------------- NVOL=NVOL+1 IF (NFV(1,IF1).EQ.0) NFV(1,IF1)=NVOL IF (NFV(1,IF1).NE.NVOL) NFV(2,IF1)=NVOL IF (NFV(1,IF2).EQ.0) NFV(1,IF2)=NVOL IF (NFV(1,IF2).NE.NVOL) NFV(2,IF2)=NVOL IF (NFV(1,IF3).EQ.0) NFV(1,IF3)=NVOL IF (NFV(1,IF3).NE.NVOL) NFV(2,IF3)=NVOL IF (NFV(1,IF4).EQ.0) NFV(1,IF4)=NVOL IF (NFV(1,IF4).NE.NVOL) NFV(2,IF4)=NVOL IF (NFV(1,IF5).EQ.0) NFV(1,IF5)=NVOL IF (NFV(1,IF5).NE.NVOL) NFV(2,IF5)=NVOL IVOL(9,NVOL)=35 DO 170 I=1,4 IVOL(I,NVOL)=NFC(I,IF2) 170 CONTINUE IVOL(5,NVOL)=IP1 C * WRITE(6,1100)NVOL,(IVOL(I,NVOL),I=1,9) *1100 FORMAT(I3,4X,14I4) if (iimpi.eq.1) write (6,1100) nfacet,(ivol(i,nvol),i=1,5) 1100 FORMAT(' PYRA1 facettes ',i5,' pyr5 ',5i5) C * DO 180 J=1,NPTMAX * WRITE(6,1110)J,(NPF(I,J),I=1,40) *1110 FORMAT(I4,4X,40I3) *180 CONTINUE C C IGAGNE=1 C RETURN C 190 CONTINUE C C LE VOLUME CREE EST INVALIDE: IL FAUT DONC DETRUIRE LES FACETTES C CREES. -------------------------------------------------------- CALL REPSUB(IF1) CALL REPSUB(IF2) CALL REPSUB(IF3) CALL REPSUB(IF4) CALL REPSUB(IF5) C NFCMAX=NFCMAX-ICTF C GOTO 9000 C 9000 CONTINUE IF (IBOUT.EQ.1) RETURN IF (N3.NE.0) CALL COMBL3(II,IF1,IF2,N3,IGAGNE) IF (IGAGNE.EQ.1) RETURN IF (N4.NE.0) CALL COMBL3(JJ,IF2,IF1,N4,IGAGNE) RETURN 250 CONTINUE 260 CONTINUE * CREATION POINT MILIEU NPTMAX=NPTMAX+1 XYZ(4,NPTMAX)=(XYZ(4,IP1)+XYZ(4,JP1)+XYZ(4,JP2))/3. * deplacement du point pour l'eloigner de ii jj xn1=(xyz(2,jj)-xyz(2,ii))*(xyz(3,ip1)-xyz(3,ii))- > (xyz(3,jj)-xyz(3,ii))*(xyz(2,ip1)-xyz(2,ii)) yn1=(xyz(3,jj)-xyz(3,ii))*(xyz(1,ip1)-xyz(1,ii))- > (xyz(1,jj)-xyz(1,ii))*(xyz(3,ip1)-xyz(3,ii)) zn1=(xyz(1,jj)-xyz(1,ii))*(xyz(2,ip1)-xyz(2,ii))- > (xyz(2,jj)-xyz(2,ii))*(xyz(1,ip1)-xyz(1,ii)) * scal=xn1*(xyz(1,jp1)-xyz(1,ii))+xn2*(xyz(2,jp1)-xyz(2,ii))+ * > xn3*(xyz(3,jp1)-xyz(3,ii)) * write (6,*) ' dnas tetra scal ',scal * write (6,*) ' ii ',(XYZ(i,ii),i=1,4) * write (6,*) ' jj ',(XYZ(i,jj),i=1,4) * write (6,*) ' ip ',(XYZ(i,ip),i=1,4) * write (6,*) ' jp ',(XYZ(i,jp),i=1,4) * write (6,*) ' xn ',xn1,yn1,zn1 sn1=sqrt(xn1**2+yn1**2+zn1**2) xn1=xn1/sn1 yn1=yn1/sn1 zn1=zn1/sn1 xn2=((xyz(2,jp1)+xyz(2,jp2))/2-xyz(2,ii))*(xyz(3,jj)-xyz(3,ii))- > ((xyz(3,jp1)+xyz(3,jp2))/2-xyz(3,ii))*(xyz(2,jj)-xyz(2,ii)) yn2=((xyz(3,jp1)+xyz(3,jp2))/2-xyz(3,ii))*(xyz(1,jj)-xyz(1,ii))- > ((xyz(1,jp1)+xyz(1,jp2))/2-xyz(1,ii))*(xyz(3,jj)-xyz(3,ii)) zn2=((xyz(1,jp1)+xyz(1,jp2))/2-xyz(1,ii))*(xyz(2,jj)-xyz(2,ii))- > ((xyz(2,jp1)+xyz(2,jp2))/2-xyz(2,ii))*(xyz(1,jj)-xyz(1,ii)) sn2=sqrt(xn2**2+yn2**2+zn2**2) xn2=xn2/sn2 yn2=yn2/sn2 zn2=zn2/sn2 xn=(xn1+xn2)/2 yn=(yn1+yn2)/2 zn=(zn1+zn2)/2 sn=sqrt(xn**2+yn**2+zn**2) xn=xn/sn yn=yn/sn zn=zn/sn * xmil=(xyz(1,ii)+xyz(1,jj))/2 * ymil=(xyz(2,ii)+xyz(2,jj))/2 * zmil=(xyz(3,ii)+xyz(3,jj))/2 * xv=xyz(1,jj)-xyz(1,ii) yv=xyz(2,jj)-xyz(2,ii) zv=xyz(3,jj)-xyz(3,ii) sv=sqrt(xv**2+yv**2+zv**2) xv=xv/sv yv=yv/sv zv=zv/sv xli=xv*(xyz(1,ip1)-xyz(1,ii))+yv*(xyz(2,ip1)-xyz(2,ii))+ > zv*(xyz(3,ip1)-xyz(3,ii)) xlj1=xv*(xyz(1,jp1)-xyz(1,ii))+yv*(xyz(2,jp1)-xyz(2,ii))+ > zv*(xyz(3,jp1)-xyz(3,ii)) xlj2=xv*(xyz(1,jp2)-xyz(1,ii))+yv*(xyz(2,jp2)-xyz(2,ii))+ > zv*(xyz(3,jp2)-xyz(3,ii)) xl=(xli+xlj1+xlj2+2*sv+2*0)/7 xl=0.5*sv xmil=xyz(1,ii)+xl*xv ymil=xyz(2,ii)+xl*yv zmil=xyz(3,ii)+xl*zv expf = xyz(4,nptmax) xyz(1,nptmax)=xmil+xn*expf*expfac xyz(2,nptmax)=ymil+yn*expf*expfac xyz(3,nptmax)=zmil+zn*expf*expfac * write (6,*) ' pyra1 creation de 2 elements et pt ',nptmax * write (6,*) ' coordonnees ',(XYZ(i,nptmax),i=1,4) * write (6,*) ' coordonnees ',(XYZ(i,ip),i=1,4) * write (6,*) ' coordonnees ',(XYZ(i,jp),i=1,4) * write (6,*) ' coordonnees ',xmil,ymil,zmil * CREATION DES ELEMENTS IPTT=NPTMAX CALL DIST(iptt,nptaux,GL,IOK,ii,jj,ip1,jp1,jp2,0,0,0,0,0) IF (IOK.EQ.0) THEN NPTMAX=nptini IF (IVERB.EQ.1) WRITE (6,*) ' pyra1 DIST ',nptaux * if (nptaux.eq.0) goto 9000 return iptt=nptaux ENDIF IF (gl.lt.xyz(4,iptt)/4) then IF (IVERB.EQ.1) write (6,*) 'pyra1 GL-1' nptmax=nptini return endif 253 continue IF (.NOT.IN2(ii,IPTT,nfcini).or..NOT.IN2(jj,IPTT,nfcini)) THEN NPTMAX=nptini goto 9000 ENDIF * recherche existence de la face IF3=IFACE3(ii,iptt,ip1) IF (IF3.ne.0.AND.IVERB.EQ.1) & write (6,*) ' pyra1 facette assimilee' IF (IF3.eq.0) THEN NFCMAX=NFCMAX+1 IF3=NFCMAX NFC(1,IF3)=II NFC(2,IF3)=iptt NFC(3,IF3)=IP1 NFC(4,IF3)=0 elseif (NFC(4,if3).ne.0.or.ipred(if3,ii).ne.iptt) then IF (IVERB.EQ.1) write(6,*) ' pyra1 probleme facette if3 ',if3 nptmax=nptini nfcmax=nfcini goto 9000 endif * recherche existence de la face IF4=IFACE3(ii,jp1,iptt) IF (IF4.ne.0.AND.IVERB.EQ.1) & write (6,*) ' pyra1 facette assimilee' IF (IF4.eq.0) THEN NFCMAX=NFCMAX+1 IF4=NFCMAX NFC(1,IF4)=II NFC(2,IF4)=JP1 NFC(3,IF4)=iptt NFC(4,IF4)=0 elseif (NFC(4,if4).ne.0.or.ipred(if4,ii).ne.jp1) then IF (IVERB.EQ.1) write(6,*) ' pyra1 probleme facette if4 ',if4 nptmax=nptini nfcmax=nfcini goto 9000 endif * recherche existence de la face IF5=IFACE3(jp1,jp2,iptt) IF (IF5.ne.0.AND.IVERB.EQ.1) & write (6,*) ' pyra1 facette assimilee' IF (IF5.eq.0) THEN NFCMAX=NFCMAX+1 IF5=NFCMAX NFC(1,IF5)=JP1 NFC(2,IF5)=JP2 NFC(3,IF5)=iptt NFC(4,IF5)=0 elseif (NFC(4,if5).ne.0.or.ipred(if5,jp1).ne.jp2) then IF (IVERB.EQ.1) write(6,*) ' pyra1 probleme facette if5 ',if5 nptmax=nptini nfcmax=nfcini goto 9000 endif * recherche existence de la face IF6=IFACE3(jp2,jj,iptt) IF (IF6.ne.0.AND.IVERB.EQ.1) & write (6,*) ' pyra1 facette assimilee' IF (IF6.eq.0) THEN NFCMAX=NFCMAX+1 IF6=NFCMAX NFC(1,IF6)=JP2 NFC(2,IF6)=JJ NFC(3,IF6)=iptt NFC(4,IF6)=0 elseif (NFC(4,if6).ne.0.or.ipred(if6,jp2).ne.jj) then IF (IVERB.EQ.1) write(6,*) ' pyra1 probleme facette if6 ',if6 nptmax=nptini nfcmax=nfcini goto 9000 endif * recherche existence de la face IF7=IFACE3(jj,ip1,iptt) IF (IF7.ne.0.AND.IVERB.EQ.1) & write (6,*) ' pyra1 facette assimilee' IF (IF7.eq.0) THEN NFCMAX=NFCMAX+1 IF7=NFCMAX NFC(1,IF7)=JJ NFC(2,IF7)=IP1 NFC(3,IF7)=iptt NFC(4,IF7)=0 elseif (NFC(4,if7).ne.0.or.ipred(if7,jj).ne.ip1) then IF (IVERB.EQ.1) write(6,*) ' pyra1 probleme facette if7 ',if7 nptmax=nptini nfcmax=nfcini goto 9000 endif * creation facette commune (necessaire pour faire les verification) IF8=IFACE3(ii,jj,iptt) IF (IF8.ne.0.AND.IVERB.EQ.1) & write(6,*)' pyra1 facette if8 existe deja => echec' IF (IF8.ne.0) THEN nptmax=nptini nfcmax=nfcini goto 9000 endif NFCMAX=NFCMAX+1 IF8=NFCMAX NFC(1,IF8)=ii NFC(2,IF8)=jj NFC(3,IF8)=iptt NFC(4,IF8)=0 * si necessaire verification diago * if (nptini.eq.nptmax) then IF (DIAGO(iptt,ii,diacri)) GOTO 275 IF (DIAGO(iptt,jj,diacri)) GOTO 275 IF (DIAGO(iptt,ip1,diacri)) GOTO 275 IF (DIAGO(iptt,jp1,diacri)) GOTO 275 IF (DIAGO(iptt,jp2,diacri)) GOTO 275 goto 276 275 continue nptmax=nptini nfcmax=nfcini goto 9000 276 continue * endif C CALL REPSUB(IF1) CALL REPSUB(IF3) CALL REPSUB(IF7) CALL REPSUB(IF8) * verification du premier element element IF (.NOT.SOLTET(IF1,IF3,IF7,IF8,ipin)) then IF (IVERB.EQ.1) write (6,*) 'pyra1 soltet invalide' GOTO 160 endif IF (.NOT.FACET(IF3)) then IF (IVERB.EQ.1) write(6,*) ' pyra1 facet if3 invalide' GOTO 160 ENDIF IF (.NOT.FACET(IF7)) then IF (IVERB.EQ.1) write(6,*) ' pyra1 facet if7 invalide' GOTO 160 ENDIF CALL REPSUB(IF2) CALL REPSUB(IF4) CALL REPSUB(IF5) CALL REPSUB(IF6) CALL REPSUB(IF8) * verification du deuxieme element element IF (.NOT.SOLPYR(IF2,IF4,IF5,IF6,IF8)) then IF (IVERB.EQ.1) write (6,*) 'pyra1 solpyr invalide' GOTO 165 endif IF (.NOT.FACET(IF4)) then IF (IVERB.EQ.1) write(6,*) ' pyra1 facet if4 invalide' GOTO 165 ENDIF IF (.NOT.FACET(IF5)) then IF (IVERB.EQ.1) write(6,*) ' pyra1 facet if5 invalide' GOTO 165 ENDIF IF (.NOT.FACET(IF6)) then IF (IVERB.EQ.1) write(6,*) ' pyra1 facet if6 invalide' GOTO 165 ENDIF * OK pour creation elements NVOL=NVOL+1 IF (NFV(1,IF1).EQ.0) NFV(1,IF1)=NVOL IF (NFV(1,IF1).NE.NVOL) NFV(2,IF1)=NVOL IF (NFV(1,IF3).EQ.0) NFV(1,IF3)=NVOL IF (NFV(1,IF3).NE.NVOL) NFV(2,IF3)=NVOL IF (NFV(1,IF4).EQ.0) NFV(1,IF4)=NVOL IF (NFV(1,IF4).NE.NVOL) NFV(2,IF4)=NVOL IF (NFV(1,IF5).EQ.0) NFV(1,IF5)=NVOL IF (NFV(1,IF5).NE.NVOL) NFV(2,IF5)=NVOL IVOL(9,NVOL)=35 DO 280 I=1,4 IVOL(I,NVOL)=NFC(I,IF2) 280 CONTINUE IVOL(5,NVOL)=iptt if (iimpi.eq.1) write (6,1102) nfacet,(ivol(i,nvol),i=1,5) 1102 FORMAT(' PYRA1-1 facettes ',i5,' pyr5 ',8i5) NVOL=NVOL+1 IVOL(9,NVOL)=25 IF (NFV(1,IF2).EQ.0) NFV(1,IF2)=NVOL IF (NFV(1,IF2).NE.NVOL) NFV(2,IF2)=NVOL IF (NFV(1,IF6).EQ.0) NFV(1,IF6)=NVOL IF (NFV(1,IF6).NE.NVOL) NFV(2,IF6)=NVOL IF (NFV(1,IF7).EQ.0) NFV(1,IF7)=NVOL IF (NFV(1,IF7).NE.NVOL) NFV(2,IF7)=NVOL DO 282 I=1,3 IVOL(I,NVOL)=NFC(I,IF1) 282 CONTINUE IVOL(4,NVOL)=iptt if (iimpi.eq.1) write (6,1101) nfacet,(ivol(i,nvol),i=1,4) 1101 FORMAT(' PYRA1-2 facettes ',i5,' tet4 ',8i5) * write (6,*) ' pyra1 2 elements fabriques ' * write (6,*) ' liste des facettes ' * DO 444 I=1,NFCMAX * IF (IFAT(I).EQ.1) GOTO 444 * WRITE (6,*) I,NFC(1,I),NFC(2,I),NFC(3,I),NFC(4,I) *444 CONTINUE IGAGNE=1 RETURN 165 continue CALL REPSUB(IF8) CALL REPSUB(IF6) CALL REPSUB(IF5) CALL REPSUB(IF4) CALL REPSUB(IF2) 160 continue CALL REPSUB(IF8) CALL REPSUB(IF7) CALL REPSUB(IF3) CALL REPSUB(IF1) nptmax=nptini nfcmax=nfcini goto 9000 END