MINICERN/mathlib/gen/d/epde1.F

   1 *
   2 * $Id$
   3 *
   4 * $Log$
   5 * Revision 1.1.1.1  1996/04/01 15:02:18  mclareni
   6 * Mathlib gen
   7 *
   8 *
   9 #include "gen/pilot.h"
  10       SUBROUTINE EPDE1
  11 C-----SEGMENT CHANGED FROM PROGRAM TO SUBROUTINE. LIBRARY. APRIL 72.
  12 C
  13       COMMON  C5     , C95    , NT3    , UT3    , NT4    , HT4
  14       COMMON  KT4    , NT5    , NE3    , NE4    , NE5    , NC
  15       COMMON  NR     , KODBAS , DX     , DY     , JOBNUM
  16       DIMENSION NT3(780),UT3(780),NT4(780),HT4(780,4),KT4(780),
  17      1NT5(390,2)
  18       COMMON XDATA(500),YDATA(500) , UDATA(500), NCDATA(500),NBPR(200)
  19      1     , NBPC(200) ,XB(200,20) , YB(200,20)
  20       COMMON   UBPR     , UBPC
  21       DIMENSION  KODBPR(200,20)    , KODBPC(200,20)
  22       DIMENSION  UBPR(200,20)      , UBPC(200,20)
  23       EQUIVALENCE (UBPR(1,1),KODBPR(1,1)) , (UBPC(1,1),KODBPC(1,1))
  24 C  THE FOLLOWING STATEMENT IS REQUIRED TO MAKE THE COMMON OF THE MAIN
  25 C  PROGRAM AT LEAST AS LONG AS IN A SUBROUTINE AS PER CERN FORTRAN
  26       COMMON EXTRA(2271)
  27       DIMENSION  HL(4) , UL(4)
  28       EQUIVALENCE (UWANT,NUWANT)
  29       DIMENSION KSCCP(4,4)
  30 C
  31       C5=0.0002
  32       C95=0.9998
  33       DO 1 I=1,200
  34       NBPR(I)=0
  35       NBPC(I)=0
  36       DO 1 J=1,20
  37       XB(I,J)=0
  38       YB(I,J)=0
  39       UBPR(I,J)=0
  40     1 UBPC(I,J)=0
  41       READ 100,DX,DY,NSCC,JOBNUM,KODBAS,NSCCP
  42       WRITE(6,101)JOBNUM
  43       IF(NSCCP)3,3,2
  44     2 READ 104,((KSCCP(I,J),J=1,4),I=1,NSCCP)
  45     3 KB=0
  46       DO 11 NCURVE=1,NSCC
  47       READ 102,NPTS
  48       KA=KB+1
  49       KB=KB+NPTS
  50       READ 107,(XDATA(I),YDATA(I),UDATA(I),NCDATA(I),I=KA,KB)
  51       DO 23 I=KA,KB
  52       NEARST=XDATA(I)/DX+0.5
  53       IF(ABS(XDATA(I)/DX-NEARST)-.00005)20,21,21
  54    20 XDATA(I)=XDATA(I)+.0001*DX
  55    21 NEARST=YDATA(I)/DY+0.5
  56       IF(ABS(YDATA(I)/DY-NEARST)-.00005)22,23,23
  57    22 YDATA(I)=YDATA(I)+.0001*DY
  58    23 CONTINUE
  59       XDATA(KB+1)=XDATA(KA)
  60       YDATA(KB+1)=YDATA(KA)
  61       UDATA(KB+1)=UDATA(KA)
  62       NCDATA(KB+1)=NCDATA(KA)
  63       DO 10 MP=KA,KB
  64       LP=MP+1
  65       CALL EPDBPS(YDATA(MP),YDATA(LP),XDATA(MP),XDATA(LP),UDATA(MP),
  66      1UDATA(LP),NCDATA(MP),NCDATA(LP),DY,NBPR,XB,UBPR,KODBPR)
  67       CALL EPDBPS(XDATA(MP),XDATA(LP),YDATA(MP),YDATA(LP),UDATA(MP),
  68      1UDATA(LP),NCDATA(MP),NCDATA(LP),DX,NBPC,YB,UBPC,KODBPC)
  69    10 CONTINUE
  70    11 CONTINUE
  71       NPTS=KB
  72       XMAX=XDATA(1)
  73       DO 6 J=2,NPTS
  74       IF(XDATA(J)-XMAX)6,6,5
  75     5 XMAX=XDATA(J)
  76     6 CONTINUE
  77       NC=INT(XMAX/DX)+2
  78       YMAX=YDATA(1)
  79       DO 8 J=2,NPTS
  80       IF(YDATA(J)-YMAX)8,8,7
  81     7 YMAX=YDATA(J)
  82     8 CONTINUE
  83       NR=INT(YMAX/DY)+2
  84       CALL EPDSRT(NR,NBPR,XB,UBPR)
  85       CALL EPDSRT(NC,NBPC,YB,UBPC)
  86       NE3=0
  87       NE4=0
  88       NE5=0
  89       DO 30 IR=1,NR
  90       YM=(IR-1)*DY
  91       DO 30 IC=1,NC
  92       NOFPT=(IR-1)*NC+IC
  93       XM=(IC-1)*DX
  94       CALL EPDLOC(IR,XM,XB,NBPR,UBPR,HL(3),HL(1),UL(3),UL(1),LX,DX)
  95       CALL EPDLOC(IC,YM,YB,NBPC,UBPC,HL(4),HL(2),UL(4),UL(2),LY,DY)
  96       MU=3*LX+LY+1
  97       GO TO (50,31,33,31,32,33,33,33,34),MU
  98    50 IF(NSCCP)30,30,51
  99    51 DO 52 I=1,NSCCP
 100       IF(KSCCP(I,1)-NOFPT)52,53,52
 101    52 CONTINUE
 102       GO TO 30
 103    53 DO 54 J=1,4
 104    54 HL(J)=0.0
 105       J=KSCCP(I,2)
 106       HL(J)=1.0
 107       J=KSCCP(I,4)
 108       HL(J)=1.0
 109       MKR=3
 110       NUWANT=KSCCP(I,3)
 111       GO TO 35
 112    31 CALL EPDCJ(HL,UL,MKR,UWANT)
 113       GO TO 35
 114    32 CALL EPDJE(HL,UL,MKR,UWANT)
 115       GO TO 35
 116    33 WRITE(6,103)NOFPT
 117       RETURN
 118    34 CALL EPDIN(HL,UL,MKR,UWANT)
 119    35 CALL EPDTAB(NOFPT,HL,UWANT,MKR,UWANT)
 120    30 CONTINUE
 121 C*UL 41 IF(NE4)37,37,36
 122       IF(NE4)37,37,36
 123    36 CALL EPDCHK(XDATA,YDATA,UDATA,NPTS)
 124    37 CALL EPDCHN(I,A4)
 125 C         WILL STOP IN EPDCHN, BUT IBM FORTRAN REQUIRES
 126       RETURN
 127   101 FORMAT('1 SOLVE ELLIPTIC PARTIAL DIFF. EQUN....JOB NUMBER',I6///)
 128   102 FORMAT(45X,I5)
 129   107 FORMAT(3E15.7,I5)
 130   103 FORMAT('0 COMPUTER CANNOT DECIDE WHETHER POINT NUMBER',I5,
 131      1       'IS INSIDE OR OUTSIDE THE REGION')
 132   100 FORMAT(2E15.7,15X,2I5/45X,2I5)
 133   104 FORMAT(45X,2I5)
 134       END