      SUBROUTINE START
C     ****                   STARTS THE MODEL FROM A SAVE TAPE,
C     ****                   HISTORY TAPE, OR DEADSTART
      include "params.h"
      PARAMETER (IMAXG=ZIMX, JMAXG=ZJMX)
      PARAMETER (IMAXGP=IMAXG+1, JMAXGP=JMAXG+1)
      include "blnk.h"
      include "vscr.h"
      include "buff.h"
      include "cons.h"
      include "index.h"
      include "strt.h"
      include "tlib.h"
      include "unit.h"
      include "fieldz.h"
      include "cterp.h"
      include "trig.h"
      include "dynphi.h"
      include "types.h"
      include "sechis.h"
      COMMON/RUNTIM/TTBOUND,NERD(2*ZJMX+1)
      include "amie.h"
      INTEGER STOP(3,2),unlink
      DIMENSION DTPOT1(80,49),DTPOT2(80,49),
     | DPKVA1(73,36),DVIA1(73,36,3),DKEVA1(73,36),DFLXA1(73,36),
     | DPKVA2(73,36),DVIA2(73,36,3),DKEVA2(73,36),DFLXA2(73,36)
      INTEGER STOP(3,2)
      EQUIVALENCE (INPT(106),STOP)

      PI = 4.*ATAN(1.)
      RTD = 180./PI

C     ****                   READ CONTROL PARAMETERS
      CALL INPUT
c
c assign scratch units in-core (memory resident), or out-of-core
c   (ssd), according to user input INCORE:
c
      call assign_scratch
C     ****                   DEFINE MODEL CONSTANTS
      CALL CON
C     ****
C     ****     ZERO PERIODIC POINTS IN F ARRAY AND WORKING ARRAYS
C     ****
      LIM = 15*KMAXP1+9
      DO 55 I = 1,2
        DO 55 K = 1,LIM
          S15(I,K) = 0.0
          S15(I+IMAXP2,K) = 0.0
   55 CONTINUE
      LIM = 8*NCBUF+NCPHYS
      DO 57 I = 1,IMAXP4
        DO 57 K = 1,LIM
          F(I,K) = 0.0
   57 CONTINUE
C     ****     CALCULATE DYNAMO CONSTANTS
      CALL CNSTNT
C     ****     SET TAPE CONTROL PARAMETERS
      ITAP=1
      IFIL=0
      IHIS=0
      ISAV=MSAV
      if (lusech.gt.0) then
        itapsech = 1
        ifilsech = 0
        ihissech = isecstart-iter
        isavsech = msavsech + (isecstart-iter)
      endif
C     ****     ACCESS NEEDED TAPES
      CALL ACCSTP
C     ****
C     ****     OPEN ALL DATA SETS
C     ****
      IOS1 = 0
      IF (MODEST.EQ.1)THEN
        OPEN(UNIT=ISORC,FILE='SOURCE',STATUS='OLD',IOSTAT=IOS1,ERR=1234,
     1    FORM='UNFORMATTED')
 1234   CONTINUE
        istat = unlink('HISTCPY')
        OPEN(UNIT=IHIST,FILE='HISTCPY',STATUS='NEW',IOSTAT=IOS3,
     1    ERR=3456,FORM='UNFORMATTED')
 3456   CONTINUE
        call mkvolinfo(-1,-1,-1,-1, -1,-1,-1,-1, 0,0,tgcm_version,
     +    0,volinfo)
      ELSE
        OPEN(UNIT=IHIST,FILE='HISTCPY',STATUS='OLD',IOSTAT=IOS3,
     1    ERR=7890,FORM='UNFORMATTED')
 7890   CONTINUE
      ENDIF
      OPEN(UNIT=IMAG,FILE='MAGNET',STATUS='OLD',IOSTAT=IOS2,ERR=2345,
     1  FORM='UNFORMATTED')
 2345 CONTINUE
      IOS4 = 0
      OPEN(8,FORM='UNFORMATTED')
      IOS5 = 0
      OPEN(9,FORM='UNFORMATTED')
C
      IOS6 = 0
      IOS7 = 0
      IF(IAMIE.EQ.1)THEN
	OPEN(UNIT=IUSAMI,FILE='SHAMIE',STATUS='OLD',IOSTAT=IOS6,
     1    ERR=8764,FORM='UNFORMATTED')
 8764   CONTINUE
	OPEN(UNIT=IUNAMI,FILE='NHAMIE',STATUS='OLD',IOSTAT=IOS7,
     1    ERR=8765,FORM='UNFORMATTED')
 8765   CONTINUE
      ENDIF
c
c Open unit for secondary history volumes if lusech > 0:
c
      if (lusech.gt.0) then
        istat = unlink('SECHIST')
        open(unit=lusech,file='SECHIST',status='NEW',iostat=ios9,
     +    form='UNFORMATTED')
        if (ios9.eq.0) then
          write(6,"('start: opened unit ',i2,' for secondary ',
     +      'histories')") lusech
        else
          write(6,"('>>> start: error opening SECHIST',
     +      ' (status=NEW) lusech=',i2,' ios9=',i4)") lusech,ios9
        endif
        call mkvolinfo(-1,-1,-1,-1, -1,-1,-1,-1, 0,0,tgcm_version,
     +    1,volinfo_sech)
c
c Open direct access unit for non-primary secondary history fields:
c (note record length is in bytes. See addfsech.f for write and mkfsech.f
c  for read of this file)
c
        istat = unlink('SECHIST1')
        open(lusech1,file="SECHIST1",form='UNFORMATTED',access="DIRECT",
     +    recl=zimxp*zkmxp*8,iostat=ios)	! recl=76*45*8=3420*8=15200
        if (ios.eq.0) then
          write(6,"('Opened direct access unit ',i2,' for diagnostic',
     +      ' secondary history fields')") lusech1
        else
          write(6,"('>>> INPUT WARNING: error opening diagnostic',
     +      ' secondary history field unit ',i2)") lusech1
        endif
      endif
      IF(IOS1+IOS2+IOS3+IOS4+IOS5+IOS6+IOS7.NE.0)THEN
	write(6,"(1x,'START --- Problem opening files or not enough',
     |   ' memory, IOS=',7I5)") IOS1,IOS2,IOS3,IOS4,IOS5,IOS6,IOS7
	STOP
      ENDIF

C     ****     Check information on AMIE volumes
      IF (IAMIE .EQ. 1) THEN
C     ****     IH=1,2 for SH and NH
	DO 2500 IH=1,2
	 IUAMI = IUSAMI
	 IF (IH .EQ. 2) IUAMI = IUNAMI
C       ****     IYDA1 = YYDDD YEAR AND DAYNUMBER OF THE FIRST AMIE READ
C       ****     IUTS1,2 = FIRST AND LAST UT SEC OF AMIE READS
C       ****     NSCINT = NUMBER OF SECONDS ALLOWED FOR EXTRAPOLATION
C       ****     NTIMS = NUMBER OF TIMES WITH AMIE PATTERNS
C       ****     IGAMIE,JGAMIE = DIMENSIONS OF GEOGRAPHIC ARRAYS
C       ****             (SHOULD BE SAME AS TIGCM, I.E. 73,36)
C       ****     JHGAMIE = JGAMIE/2 (I.E. SHOULD BE 18)
C       ****     IMAMIE,JMAMIE = DIMENSIONS OF MAGNETIC ARRAYS
C       ****             (SHOULD BE SAME AS TIGCM, I.E. 80,97)
C       ****     JHMAMIE = JMAMIE/2+1 (I.E. SHOULD BE 49)
C       ****     NOTE DIMENSIONS OF DTPOT(IMAMIE,JHMAMIE) ARE FOR HALF THE
C       ****      GLOBE AND OF TIEPOT(IMAMIE+1,JMAMIE) ARE WHOLE GLOBE
C       ****     ICONJ = 1,0  IF DO,NOT ASSUME CONJUGACY FOR THE AURORAL
C       ****             ENERGY FLUX AND MEAN ENERGY.  IF SO, USE WHOLE
C       ****             GLOBE VALUES, IF NOT, USE SPECIFIC HEMISPHERE.
	fackv = 1.
	READ (IUAMI) IYDA1, IUTS1, IYDA2, IUTS2, NSCINT, NTIMS(IH),
     |   IGAMIE,JGAMIE,JHGAMIE,JMAMIE,JHMAMIE,IMAMIE,ICONJ
C  TEMP for May 1996 background vol!!
cc      iuts1 = 18*3600*24 + 17*3600 + 1800
cc      iuts2 = 19*3600*24 + 17*3600 + 1800
C  TEMP since UTSA is screwed up in fndutsa if iconj = 1 (and is
C   irrelevant for May 1996 since I2HEM=0 so times are the same!!)
	ICONJ = 0
	nscint = 31.*60.
	fackv = 1.
C  Lummerzheim gave me characteristic energy, not mean energy!!
	WRITE (6,"(1X,' READ AMIE VOLUME FOR HEM IYDA1,2 IUTS1,2 ',
     1    'NSCINT NTIMS ICONJ =', I2,5I8,I4,I2)") IH,IYDA1,IYDA2,IUTS1,
     2    IUTS2,NSCINT,NTIMS(IH),ICONJ
	IYD1 = (IYEAR-1900)*1000 + IIDAY
	IUTSMOD = ITER*C(4)
	SECTGCM = IUTSMOD
	IUTSMEND = (STOP(1,1)*24*60 + STOP(2,1)*60 + STOP(3,1))*60
	WRITE (6,"(1X,' TIGCM RUN BEGINS AT IYD IUTS =', 2I8,' AND ',
     1    'ENDS AT IUTS =',I8)")  IYD1,IUTSMOD,IUTSMEND
       IF (IUTSMOD.LT.IUTS1-NSCINT .OR. IUTSMEND.GT.IUTS2+NSCINT) THEN
	 WRITE (6,"(1X,' TIGCM begin IUTS or end IUTS is out of ',
     |     'range (+/-NSCINT) of the AMIE volume --- STOP.')")
	  STOP
	ENDIF
	IF (ZIMX .NE. IGAMIE-1 .OR. ZJMX .NE. JGAMIE) THEN
	  WRITE (6,"(1X,'DIMENSIONS OF IMX AND JMX OF TIGCM ARE ',
     1      'INCOMPATIBLE WITH THE DIMENSIONS OF AMIE',2I3,
     2      ' --- STOP.')") IGAMIE,JGAMIE
	  STOP
	ENDIF
C       ****      For TIE-GCM only
	IF (IMAXM .NE. IMAMIE .OR. JMAXM .NE. JMAMIE) THEN
	  WRITE (6,"(1X,'DIMENSIONS OF DISTORTED MAG GRID OF TIGCM ARE',
     1      ' INCOMPATIBLE WITH THE DIMENSIONS OF AMIE',2I3,
     2      ' --- STOP.')") IMAMIE,JMAMIE
	  STOP
	ENDIF
C       ****      Read first 2 times needed
C  TEMP  eliminate 1705-1735 UT on March 21, 1990  (#494-500)
C       if (ntims(ih) .eq. 576) NTIMS(IH) = NTIMS(IH)-7
	DO 60 N=1,NTIMS(IH),2
C  Yes UTSA and ICONJ for Jan 1993
C       READ (IUAMI) UTSA(1,IH),HPA(1,IH),CPA(1,IH),CUSPTA(1,IH),
C    1    CUSPLA(1,IH),ICONJ,DPKVA1,DTPOT1,DVIA1,DKEVA1,DFLXA1
C  Yes IUTSA and no ICONJ for Jan 1988, Mar 1990, Mar 1992
	READ (IUAMI) IUTSA,     HPA(1,IH),CPA(1,IH),CUSPTA(1,IH),
     1    CUSPLA(1,IH),      DPKVA1,DTPOT1,DVIA1,DKEVA1,DFLXA1
	UTSA(1,IH) = IUTSA
	UTSP(1,IH) = UTSA(1,IH)
	write (6,"(1x,'ih n uts hp cp=',2i3,f9.0,2f6.1)") ih,n,
     |   utsa(1,ih),hpa(1,ih),cpa(1,ih)
C  TEMP  eliminate 1705-1735 UT on March 21, 1990  (#494-500)
C       if (n .eq. 493) then
C        do 599 n2=1,7
C         READ (IUAMI) IUTSA,     HPA(2,IH),CPA(2,IH),CUSPTA(2,IH),
C    1    CUSPLA(2,IH),      DPKVA2,DTPOT2,DVIA2,DKEVA2,DFLXA2
C         write (6,"(1x,'skip n2 hp cp=',i3,2f6.1)") n2,hpa(2,ih),
C    |     cpa(2,ih)
C599     continue
C       endif
	IF (UTSA(1,IH) .GT. SECTGCM .AND. N .NE. 1) GO TO 71
	IF (N .EQ. NTIMS(IH)) GO TO 71
	READ (IUAMI) IUTSA,     HPA(2,IH),CPA(2,IH),CUSPTA(2,IH),
     1    CUSPLA(2,IH),      DPKVA2,DTPOT2,DVIA2,DKEVA2,DFLXA2
	UTSA(2,IH) = IUTSA
	write (6,"(1x,'ih n+1 uts hp cp=',2i3,f9.0,2f6.1)") ih,n+1,
     |   utsa(2,ih),hpa(2,ih),cpa(2,ih)
	UTSP(2,IH) = UTSA(2,IH)
	IF (UTSA(2,IH) .GT. SECTGCM .OR. N+1 .EQ. NTIMS(IH)) GO TO 61
   60   CONTINUE
C       ****      Set dummy1 in array1, dummy2 in array2 for hemisphere
   61   NTST(IH) = N+1
	UTSASN(1,IH) = UTSP(1,IH)
	UTSASN(2,IH) = UTSP(2,IH)
	HPASN(1,IH) = HPA(1,IH)
	HPASN(2,IH) = HPA(2,IH)
	JA = 0
	IF (IH .EQ. 2) JA = JHGAMIE
	DO 62 I=1,IGAMIE
	DO 621 J=1,JGAMIE
	EKEVASN(I,J,1,IH) = DKEVA1(I,J) * fackv
	EFLXASN(I,J,1,IH) = DFLXA1(I,J)
	EKEVASN(I,J,2,IH) = DKEVA2(I,J) * fackv
	EFLXASN(I,J,2,IH) = DFLXA2(I,J)
 621    CONTINUE
	DO 62 J=1,JHGAMIE
	POTKVA1(I,J+JA) = DPKVA1(I,J+JA)
	EKEVA1(I,J+JA) = DKEVA1(I,J+JA) * fackv
	svEKEVA1(I,J+JA) = DKEVA1(I,J+JA) * fackv
	EFLXA1(I,J+JA) = DFLXA1(I,J+JA)
	POTKVA2(I,J+JA) = DPKVA2(I,J+JA)
	EKEVA2(I,J+JA) = DKEVA2(I,J+JA) * fackv
	svEKEVA2(I,J+JA) = DKEVA2(I,J+JA) * fackv
	EFLXA2(I,J+JA) = DFLXA2(I,J+JA)
	DO 62 K=1,3
	VIXYZA1(I,J+JA,K) = DVIA1(I,J+JA,K)
   62   VIXYZA2(I,J+JA,K) = DVIA2(I,J+JA,K)
	IF (IH .EQ. 1) THEN
	 DO 64 J=1,JHMAMIE
	 DO 63 I=1,IMAMIE
	 TIEPOT1(I,J) = DTPOT1(I,J)
   63    TIEPOT2(I,J) = DTPOT2(I,J)
	 TIEPOT1(IMAMIE+1,J) = TIEPOT1(1,J)
   64    TIEPOT2(IMAMIE+1,J) = TIEPOT2(1,J)
	ELSE
	 DO 67 J=1,JHMAMIE
	 DO 66 I=1,IMAMIE
	 TIEPOT1(I,JMAMIE+1-J) = DTPOT1(I,J)
   66    TIEPOT2(I,JMAMIE+1-J) = DTPOT2(I,J)
	 TIEPOT1(IMAMIE+1,JMAMIE+1-J) = TIEPOT1(1,JMAMIE+1-J)
   67    TIEPOT2(IMAMIE+1,JMAMIE+1-J) = TIEPOT2(1,JMAMIE+1-J)
	ENDIF
	GO TO 80
C       ****      Set dummy1 in array2, dummy2 in array1 for hemisphere
   71   NTST(IH) = N
	UTSPSV1 = UTSP(1,IH)
	HPASV1 = HPA(1,IH)
	CPASV1 = CPA(1,IH)
	CSPT1 = CUSPTA(1,IH)
	CSPL1 = CUSPLA(1,IH)
	UTSP(1,IH) = UTSP(2,IH)
	UTSA(1,IH) = UTSP(2,IH)
	UTSASN(1,IH) = UTSP(2,IH)
	UTSA(2,IH) = UTSPSV1
	UTSASN(2,IH) = UTSPSV1
	UTSP(2,IH) = UTSPSV1
	HPA(1,IH) = HPA(2,IH)
	HPASN(1,IH) = HPA(2,IH)
	HPA(2,IH) = HPASV1
	HPASN(2,IH) = HPASV1
	CPA(1,IH) = CPA(2,IH)
	CPA(2,IH) = CPASV1
	CUSPTA(1,IH) = CUSPTA(2,IH)
	CUSPTA(2,IH) = CSPT1
	CUSPLA(1,IH) = CUSPLA(2,IH)
	CUSPLA(2,IH) = CSPL1
	JA = 0
	IF (IH .EQ. 2) JA = JHGAMIE
	DO 72 I=1,IGAMIE
	DO 622 J=1,JGAMIE
	EKEVASN(I,J,1,IH) = DKEVA2(I,J) * fackv
	EFLXASN(I,J,1,IH) = DFLXA2(I,J)
	EKEVASN(I,J,2,IH) = DKEVA1(I,J) * fackv
	EFLXASN(I,J,2,IH) = DFLXA1(I,J)
 622    CONTINUE
	DO 72 J=1,JHGAMIE
	POTKVA1(I,J+JA) = DPKVA2(I,J+JA)
	EKEVA1(I,J+JA) = DKEVA2(I,J+JA) * fackv
	svEKEVA1(I,J+JA) = DKEVA2(I,J+JA) * fackv
	EFLXA1(I,J+JA) = DFLXA2(I,J+JA)
	POTKVA2(I,J+JA) = DPKVA1(I,J+JA)
	EKEVA2(I,J+JA) = DKEVA1(I,J+JA) * fackv
	svEKEVA2(I,J+JA) = DKEVA1(I,J+JA) * fackv
	EFLXA2(I,J+JA) = DFLXA1(I,J+JA)
	DO 72 K=1,3
	VIXYZA1(I,J+JA,K) = DVIA2(I,J+JA,K)
   72   VIXYZA2(I,J+JA,K) = DVIA1(I,J+JA,K)
	IF (IH .EQ. 1) THEN
	 DO 74 J=1,JHMAMIE
	 DO 73 I=1,IMAMIE
	 TIEPOT1(I,J) = DTPOT2(I,J)
   73    TIEPOT2(I,J) = DTPOT1(I,J)
	 TIEPOT1(IMAMIE+1,J) = TIEPOT2(1,J)
   74    TIEPOT2(IMAMIE+1,J) = TIEPOT1(1,J)
	ELSE
	 DO 77 J=1,JHMAMIE
	 DO 76 I=1,IMAMIE
	 TIEPOT1(I,JMAMIE+1-J) = DTPOT2(I,J)
   76    TIEPOT2(I,JMAMIE+1-J) = DTPOT1(I,J)
	 TIEPOT1(IMAMIE+1,JMAMIE+1-J) = TIEPOT2(1,JMAMIE+1-J)
   77    TIEPOT2(IMAMIE+1,JMAMIE+1-J) = TIEPOT1(1,JMAMIE+1-J)
	ENDIF
   80   CONTINUE
 2500   CONTINUE
C       ****      If ICONJ=1, find times closest to SECTGCM and
C       ****      substitute values in opposite hemisphere for FLX,KEV
	if (iconj .eq. 1) call fndutsa
c       CALL EZCNTR (potkva1,73,36)
c       CALL EZCNTR (eflxa1,73,36)
c       CALL EZCNTR (ekeva1,73,36)
c	CALL EZCNTR (tiepot1,81,20)
c	CALL EZCNTR (tiepot2,81,20)
c	CALL EZCNTR (eflxa1,73,10)
c	CALL EZCNTR (eflxa2,73,10)
c	CALL EZCNTR (ekeva1,73,10)
c	CALL EZCNTR (ekeva2,73,10)
	DO 2900 IH=1,2
	WRITE (6,"(1X,'AMIE VOLUME:  HEM NTST =',I2,I4)") IH,NTST(IH)
	WRITE (6,"(1X,'UTSA1 HP =',F9.0,F7.2,' UTSP1 CP MLT LAT=',
     |    F9.0,3F7.2)") UTSA(1,IH),HPA(1,IH),UTSP(1,IH),CPA(1,IH),
     |    CUSPTA(1,IH),CUSPLA(1,IH)
	WRITE (6,"(1X,'UTSA2 HP =',F9.0,F7.2,' UTSP2 CP MLT LAT=',
     |    F9.0,3F7.2)") UTSA(2,IH),HPA(2,IH),UTSP(2,IH),CPA(2,IH),
     |    CUSPTA(2,IH),CUSPLA(2,IH)
 2900   CONTINUE
      ENDIF                      !  FOR IAMIE=1
C     ****                   HISTORY TAPE START - SEARCH FOR FILE
   70 IDATE(1)=OR(DATE(1.),0)
      ISTRT=ISORC
      IF(MODEST.LT.0) ISTRT=IHIST
      IF(MODEST.EQ.-1) THEN
          INPT(147)=INPT(103)
          INPT(148)=INPT(104)
          INPT(149)=INPT(105)
      END IF
   75 BUFFER IN (ISTRT,1) (ITERT,ITERT(512))
      IF(UNIT(ISTRT)) 90,5000,5000
   90 BUFFER IN (ISTRT,1) (F(1,1),F(100,1))
      IF(UNIT(ISTRT)) 110,5000,5000
  110 WRITE(6,115)(ITERT(N+1),N=1,3),(INPT(N+146),N=1,3)
  115 FORMAT(* READING TIME *I2*:*I2*:*I2* SEEKING TIME *I2*:*I2*:*I2)
c
c If searching OUTPUT volume, construct volinfo each time history is read 
c   (use input DATE for iyd rather than header just read).
c volinfo is written to mss file comment field.
c
      if (modest.lt.0) then
        iend_iyd = (inpt(41)-1900)*1000+inpt(42)
        iend_day = itert(2)
        iend_hr = itert(3)
        iend_min = itert(4)
        idelmin = 0
        iendonly = 0
        if (isearch.eq.1) then	! first history found
          ibeg_iyd = (inpt(41)-1900)*1000+inpt(42)
          ibeg_day = itert(2)
          ibeg_hr = itert(3)
          ibeg_min = itert(4)
        else			! not first history found
          idelmin = (iend_hr-ibeg_hr)*60 + (iend_min-ibeg_min)
          iendonly = 1
        endif
        call mkvolinfo(ibeg_iyd,ibeg_day,ibeg_hr,ibeg_min,
     +                 iend_iyd,iend_day,iend_hr,iend_min,
     +                 idelmin,iendonly,tgcm_version,0,volinfo)
      endif
      IFIL=IFIL+1
      IF(IFIL.NE.1) GO TO 116
      IDAY(1) = ITERT(2)
      IHR(1)  = ITERT(3)
  116 CONTINUE
      IF (ITERT(2).EQ.INPT(147).AND.ITERT(3).EQ.INPT(148).AND.ITERT(4)
     1.EQ.INPT(149)) GO TO 140
      DO 130 J=1,JMAX
      BUFFER IN (ISTRT,1) (DUM,DUM)
      IF(UNIT(ISTRT)) 130,5000,5000
  130 CONTINUE
      GO TO 75
C     ****                   LOAD DISK FROM HISTORY TAPE
  140 MODULO=3
      CALL INIT
C     ****                   TRANSFER LINE 1 FROM TAPE TO SCM
      CALL FLIP
      CALL UNLCRD(ISTRT,NJ,LBSCM,NSIN)
      CALL UNLCCK(ISTRT,NSIN,LENH)
      IF(NSIN.EQ.0)
     1GO TO 150
      NUM=150
      GO TO 5000
C     ****                   GENERAL LINE LOOP
  150 DO 240 J=1,JMAX
      CALL FLIP
      IF(J.EQ.1) GO TO 160
C     ****                   START LINE J-1 FROM SCM TO DISK
      CALL UNLCWT(IUNIN,NJM2,LBDSKI,NSOT)
  160 IF(J.EQ.JMAX) GO TO 170
C     ****                   START LINE J+1 FROM TAPE TO SCM
      CALL UNLCRD(ISTRT,NJ,LBSCM,NSIN)
C     ****                   CHANGE DATA STRUCTURE FROM
C     ****                   EXTERNAL TO INTERNAL FORMAT
  170 NJM1K = NJM1
      NXK   = NJM1+NCOLS
      IXK   = LBTAP
      DO 175 NB=1,NCOLS
        IYK   = IMAXP4
        NXK = NXK-1
        DO 175 I=1,IMAXP2
          F(IYK,NXK) = F(IXK,NJM1K)
          IXK = IXK-1
          IYK = IYK-1
  175 CONTINUE
C     ****                   ADD PERIODIC POINTS
      DO 180 NXK = NJM1,NJM1+NCOLS-1
      F(     1,NXK) = F(IMAX+1,NXK)
      F(     2,NXK) = F(IMAX+2,NXK)
      F(IMAX+3,NXK) = F(     3,NXK)
      F(IMAX+4,NXK) = F(     4,NXK)
  180 CONTINUE
      IF(LENH.LT.LBTAP)THEN
C       IF(J.EQ.18)THEN
C         ****
C         ****     Write column before moving data
C         ****
C         IINDEX = NNDEXA(2)
C         NNXK =NJM1 + IINDEX - 1
C         DO K = 1,NNCOLS
C           NNXK = NNXK+1
C           WRITE(6,*)K,F(36,NNXK)
C         ENDDO
C       ENDIF
C       ****
C       ****     Now move data starting with last field
C       ****
        DO N = NTAPE,1,-1
          INDEX = NDEXA(N+1)
          IINDEX = NNDEXA(N+1)
          IF (KFLDS(N).EQ.1) THEN
            K = 1
            KK = 1
            LEN = LEN1
            LLEN = LEN1
          ELSEIF (KFLDS(N).EQ.2) THEN
            K = KMAX
            KK = K-4
            LEN = LEN2
            LLEN = LLEN2
          ELSEIF (KFLDS(N).EQ.3) THEN
            K = KMAXP1
            KK = K-4
            LEN = LEN3
            LLEN = LLEN3
          ELSE
            WRITE(6,*)'KFLDS for N = ',N,' is ',KFLDS(N)
            STOP
          ENDIF
C         ****
C         ****    Move field N
C         ****
          NXK = NJM1 + INDEX
          NNXK = NJM1 + IINDEX
          DO I = LLEN,1,-1
            F(I,NXK) = F(I,NNXK)
          ENDDO
C         ****
C         ****     Fill extra levels if K.NE.1
C         ****
          IF (K.NE.1) THEN
            NNXK = NXK + KK - 1
            NNNXK = NXK + K - 1
C           ****
C           ****     Move old top level to position of new top level
C           ****
C           ****
            DO I = 1,LEN1
              F(I,NNNXK) = F(I,NNXK)
            ENDDO
            NXK = NNXK
            DO KKK = KK+1,K
              NXK = NXK+1
              DO I = 1,LEN1
                F(I,NXK-1) = F(I,NNXK-1)
              ENDDO
            ENDDO
          ENDIF
        ENDDO
C       IF(J.EQ.18)THEN
C         ****
C         ****     Write modified column
C         ****
C         INDEX = NDEXA(2)
C         NXK = NJM1 + INDEX - 1
C         DO K = 1,NCOLS
C           NXK = NXK+1
C           WRITE(6,*)K,F(36,NXK)
C         ENDDO
C       ENDIF
      ENDIF
C     ****
C     ****     Fill array DYNPOT
C     ****
        NPHIK = NJM1+NPHI-1
        DO 340 K = 1,KMAXP1
          NPHIK = NPHIK+1
          DO 340 I = 1,IMAX+1
            DYNPOT(I,J,K) = F(I+2,NPHIK)
  340   CONTINUE
C
C     ****                   CHECK FOR COMPLETION OF BUFFERING
      IF(J.EQ.1) GO TO 230
      CALL UNLCCK(IUNIN,NSOT,LEN)
      IF(LEN.EQ.LBDSKI.AND.NSOT.EQ.0) GO TO 230
      NUM=230
      GO TO 4000
  230 IF(J.EQ.JMAX) GO TO 240
      CALL UNLCCK(ISTRT,NSIN,LENH)
      IF(NSIN.EQ.0)
     1GO TO 240
      NUM=240
      GO TO 5000
  240 CONTINUE
C     ****                   TRANSFER LINE JMAX FROM SCM TO DISK
      CALL FLIP
      CALL UNLCWT(IUNIN,NJM2,LBDSKI,NSOT)
      CALL UNLCCK(IUNIN,NSOT,LEN)
      IF(LEN.EQ.LBDSKI.AND.NSOT.EQ.0) GO TO 250
      NUM=250
      GO TO 4000
  250 ISAV=MSAV
      REWIND IUNIN
      IHIS=MHIS
      ITAP=1
      IF(IFIL.LT.MFIL)GO TO 330
      IFIL=0
      ITAP=2
      REWIND ISTRT
  330 CONTINUE
C     ****
C     ****     INSERT POLAR POINTS IN DYNPOT
C     ****
C     ****
      DO 344 K = 1,KMAXP1
        DYNPOT(1,0,K) = (9.*SSUM(IMAXG,DYNPOT(1,1,K),1)-
     1    SSUM(IMAXG,DYNPOT(1,2,K),1))/(8.*FLOAT(IMAXG))
        DYNPOT(1,JMAXGP,K) = (9.*SSUM(IMAXG,DYNPOT(1,JMAXG,K),1)
     1    -SSUM(IMAXG,DYNPOT(1,JMAXG-1,K),1))/(8.*FLOAT(IMAXG))
        DO 346 I = 2,IMAXGP
          DYNPOT(I,0,K) = DYNPOT(1,0,K)
          DYNPOT(I,JMAXGP,K) = DYNPOT(1,JMAXGP,K)
  346   CONTINUE
  344 CONTINUE
      write(6,"('call START: DYNPOT')")
c     dmax = maxval(dynpot(1:imaxgp,0:jmaxgp,kmaxp))
c     dmin = minval(dynpot(1:imaxgp,0:jmaxgp,kmaxp))
c     write(6,"('dynpot dmin,dmax=',2e12.4)") dmin,dmax
c     CALL MKCON(DYNPOT(1:imaxgp,0:jmaxgp,KMAXP),IMAXGP,JMAXGP+1,
c    1   0.,0,'GLONG','GLAT','START: DYNPOT')
C     ****
C     ****     VALUE OF T AT LOWER BOUNDARY AND GRADIENT
C     ****
      TBOUND = TTBOUND
      TGRAD = 6.
      T0(1) = TBOUND
      T0(2) = TBOUND+C(3)*TGRAD
      CALL BNDRY
      CALL BNDRY2
      CALL BNDRYA
C     ****     SET T0=0.
      DO 261 K=1,KMAX
      T0(K)=0.
  261 CONTINUE
      T0(KMAXP1)=0.
C     ****     READ MAGNETIC DATA FOR DYNAMO
      BUFFER IN(IMAG,1)(ALATM(1,0),RJACD(ZIMXP1,ZJMXP1))
      IF(UNIT(IMAG))3,4,4
    4   IUNIT = IMAG
        WRITE(6,100)IUNIT
  100   FORMAT(* PROBLEM READING TGCM FIELDS FROM UNIT *,I5)
        CALL EXIT
    3 CONTINUE
      BUFFER IN(IMAG,1)(IG(1,1),DJM(ZIMXP1,ZJMXP1))
      IF(UNIT(IMAG))5,6,6
    6   IUNIT = IMAG
        WRITE(6,100)IUNIT
        CALL EXIT
    5 CONTINUE
      BUFFER IN(IMAG,1)(CSLATM(1,1),SNLONG(ZIMXP1))
      IF(UNIT(IMAG))7,8,8
    8   IUNIT = IMAG
        WRITE(6,100)IUNIT
        CALL EXIT
    7 CONTINUE
      CALL MAGDYN
C     ****
C     ****     TRANSFORM DYNPOT TO GEOMAGNETIC COORDINATES IN
C     ****       PHIM3D(IMAXMP,JMAXM,-2:ZKMXP)
C     ****
      DO 343 K = 1,KMAXP1
        DO 343 J = 1,JMAXM
          CALL GRDINT(PHIM3D(1,J,K),DYNPOT(1,0,K),IG,JG,WT,IMAXGP,
     1      IMAXMP,IMAXG,JMAXG+2,IMAXM,JMAXM,J)
  343 CONTINUE
C     ****
C     ****     PERIODIC POINTS
C     ****
      DO 348 K = 1,KMAXP1
        DO 348 J = 1,JMAXM
          PHIM3D(IMAXMP,J,K) = PHIM3D(1,J,K)
  348 CONTINUE
C     ****
C     ****     DELETE SOURCE AND MAGNETIC DATA FILES
C     ****
      IF(ISTRT.EQ.ISORC)THEN
        CLOSE(ISORC)
        ISTAT = UNLINK('SOURCE')
        IF(ISTAT.NE.0)THEN
          WRITE(6,9012)ISTAT
 9012     FORMAT(* START --- PROBLEM DELETING SOURCE FILE, ISTAT=*,I2)
          STOP
        ENDIF
      ENDIF
C     ****
C     ****     DELETE MAGNETIC DATA FILE
C     ****
      CLOSE(IMAG)
      ISTAT = UNLINK('MAGNET')
      IF(ISTAT.NE.0)THEN
        WRITE(6,9876)ISTAT
 9876   FORMAT(* START --- PROBLEM DELETING MAGNETIC FILE, ISTAT=*,I2)
        STOP
      ENDIF
      IF(MODEST.LT.0) RETURN
C     ****                   INITIALIZE FOR NEW HISTORY TAPE
      IFIL=0
      IHIS=0
      ITAP=1
      RETURN
 4000 WRITE(6,4010) NUM,LEN,NSOT,J
 4010 FORMAT(*1DISK PROBLEM IN START AT NUM=*I5,2X,*LEN=*I5,2X,*NSOT=*
     AI1,2X,*J=*I2)
      CALL EXIT
 5000 WRITE(6,5010) NUM,LEN,NSIN,J
 5010 FORMAT(*1HIST PROBLEM IN START AT NUM=*I5,2X,*LEN=*I5,2X,*NSIN=*
     AI1,2X,*J=*I2)
      CALL EXIT
 6000 WRITE(6,6010)NUM,LEN,NSUT,J
 6010 FORMAT(*1DISK PROBLEM IN START. NUM=*I5,2X,*LEN=*I5,2X,*NSUT=*I5,
     A2X,*J=*I2)
      CALL EXIT
 1020 FORMAT(//* HISTORY TAPE LABELS*/(10A12))
 1030 FORMAT(//* SAVE TAPE LABELS*/(10A12))
      END
C
