c ******************** CONTR ********************* c c DRAW CONTOURS OF THE POTENTIAL DISTRIBUTIONS c SUBROUTINE CONTR(ETA1,VAC,TIP,SEM,VSINT,R,S,DELV,NRDIM,NVDIM, &NSDIM,NR,NV,NS,NUMC,DELP) C C NUMC=NUMBER OF CONTOURS C DELP=SPACING OF POTENTIAL CONTOURS (IF 0., USE MAX_P-MIN_P/(NUMC+1)) C DIMENSION VAC(2,NRDIM,NVDIM),SEM(2,NRDIM,NSDIM),VSINT(2,NRDIM), &R(NRDIM),S(NSDIM),DELV(NRDIM) LOGICAL TIP(NRDIM,NVDIM),KDONE(1000) C C DRAW TIP C NRSKIP=NR/500 IF (NRSKIP.EQ.0) NRSKIP=1 DO 300 I=0,NR,NRSKIP II=I IF (II.EQ.0) II=1 RSAV=R(II) IF (I.EQ.0) RSAV=-RSAV DO 250 J=1,NV IF (.NOT.TIP(II,J)) GO TO 250 WRITE(20,*) RSAV*SQRT(1.-(ETA1*J/NV)**2),-J*DELV(II) GO TO 300 250 CONTINUE 300 CONTINUE C C SEARCH FOR MIN, MAX POINTS IN POTENTIAL C PMIN=1.E10 PMAX=-1.E10 DO 400 I=1,NR DO 330 J=1,NV IF (PMIN.LT.VAC(1,I,J)) GO TO 320 PMIN=VAC(1,I,J) 320 IF (PMAX.GT.VAC(1,I,J)) GO TO 330 PMAX=VAC(1,I,J) 330 CONTINUE IF (PMIN.LT.VSINT(1,I)) GO TO 340 PMIN=VSINT(1,I) 340 IF (PMAX.GT.VSINT(1,I)) GO TO 350 PMAX=VSINT(1,I) 350 DO 370 J=1,NS IF (PMIN.LT.SEM(1,I,J)) GO TO 360 PMIN=SEM(1,I,J) 360 IF (PMAX.GT.SEM(1,I,J)) GO TO 370 PMAX=SEM(1,I,J) 370 CONTINUE 400 CONTINUE WRITE(6,*) 'MIN, MAX POTENTIAL VALUES =',PMIN,PMAX WRITE(16,*) 'MIN, MAX POTENTIAL VALUES =',PMIN,PMAX C C DRAW CONTOURS C IF (DELP.NE.0.) GO TO 450 DELP=(PMAX-PMIN)/(NUMC+1) WRITE(6,*) 'CONTOUR SPACING =',DELP WRITE(16,*) 'CONTOUR SPACING =',DELP C 450 DO 600 I=0,NR,NRSKIP II=I IF (II.EQ.0) II=1 RSAV=R(II) IF (I.EQ.0) RSAV=-RSAV DO 500 K=1,NUMC KDONE(K)=.FALSE. 500 CONTINUE DO 530 K=1,NUMC DO 520 J=NS,1,-1 P=K*DELP+PMIN IF (J.EQ.1) GO TO 510 IF ((SEM(1,II,J).GE.P.AND.SEM(1,II,J-1).LE.P).OR. & (SEM(1,II,J).LE.P.AND.SEM(1,II,J-1).GE.P)) GO TO 515 GO TO 520 510 IF ((SEM(1,II,J).GE.P.AND.VSINT(1,II).LE.P).OR. & (SEM(1,II,J).LE.P.AND.VSINT(1,II).GE.P)) GO TO 515 GO TO 520 515 WRITE(20+K,*) RSAV,S(J) KDONE(K)=.TRUE. GO TO 530 520 CONTINUE 530 CONTINUE DO 540 K=1,NUMC P=K*DELP+PMIN IF ((VSINT(1,II).GE.P.AND.VAC(1,II,1).LE.P).OR. & (VSINT(1,II).LE.P.AND.VAC(1,II,1).GE.P)) GO TO 535 GO TO 540 535 IF (.NOT.KDONE(K)) WRITE(20+K,*) RSAV,0. KDONE(K)=.TRUE. 540 CONTINUE DO 570 K=1,NUMC DO 560 J=1,NV-1 IF (TIP(II,J)) GO TO 560 P=K*DELP+PMIN IF ((VAC(1,II,J).GE.P.AND.VAC(1,II,J+1).LE.P).OR. & (VAC(1,II,J).LE.P.AND.VAC(1,II,J+1).GE.P)) GO TO 550 GO TO 560 550 IF (.NOT.KDONE(K)) & WRITE(20+K,*) RSAV*SQRT(1.-(ETA1*J/NV)**2),-J*DELV(II) KDONE(K)=.TRUE. GO TO 570 560 CONTINUE 570 CONTINUE 600 CONTINUE C DO 700 I=NR,0,-NRSKIP II=I IF (II.EQ.0) II=1 RSAV=R(II) IF (I.EQ.0) RSAV=-RSAV DO 605 K=1,NUMC KDONE(K)=.FALSE. 605 CONTINUE DO 630 K=1,NUMC DO 620 J=NV-1,1,-1 IF (TIP(II,J)) GO TO 620 P=K*DELP+PMIN IF ((VAC(1,II,J).GE.P.AND.VAC(1,II,J+1).LE.P).OR. & (VAC(1,II,J).LE.P.AND.VAC(1,II,J+1).GE.P)) GO TO 610 GO TO 620 610 IF (.NOT.KDONE(K)) & WRITE(20+K,*) RSAV*SQRT(1.-(ETA1*J/NV)**2),-J*DELV(II) KDONE(K)=.TRUE. GO TO 630 620 CONTINUE 630 CONTINUE DO 640 K=1,NUMC P=K*DELP+PMIN IF ((VSINT(1,II).GE.P.AND.VAC(1,II,1).LE.P).OR. & (VSINT(1,II).LE.P.AND.VAC(1,II,1).GE.P)) GO TO 635 GO TO 640 635 IF (.NOT.KDONE(K)) WRITE(20+K,*) RSAV,0. KDONE(K)=.TRUE. 640 CONTINUE DO 670 K=1,NUMC DO 660 J=1,NS P=K*DELP+PMIN IF (J.EQ.1) GO TO 645 IF ((SEM(1,II,J).GE.P.AND.SEM(1,II,J-1).LE.P).OR. & (SEM(1,II,J).LE.P.AND.SEM(1,II,J-1).GE.P)) GO TO 650 GO TO 660 645 IF ((SEM(1,II,J).GE.P.AND.VSINT(1,II).LE.P).OR. & (SEM(1,II,J).LE.P.AND.VSINT(1,II).GE.P)) GO TO 650 GO TO 660 650 IF (.NOT.KDONE(K)) WRITE(20+K,*) RSAV,S(J) KDONE(K)=.TRUE. GO TO 670 660 CONTINUE 670 CONTINUE 700 CONTINUE RETURN END