SUBROUTINE FOGCM(IUINPT,IPROCC)
C     ****
C     ****     THIS SUBROUTINE RUNS THE TIEGCM IN MANNER DETERMINED BY
C     ****       PARAMETERS IUINPT, IPROC AND BY CONTENTS OF LEXICAL REA
C     ****
C     ****       IUINPT = UNIT NUMBER FOR LEXICAL READ
C     ****             (= 5 FOR NORMAL MODEL RUN)
C     ****       IPROCC = 0 FOR NORMAL MODEL RUN
C     ****              = 1 FOR PROCESSOR RUN
C     ****
C     ****
C     ****                   CRAY1 VERSION OF THIRD GENERATION GCM
C     ****                   DECEMBER, 1977
C     ****
      include "params.h"
      include "blnk.h"
      include "buff.h"
      include "vscr.h"
      include "rfft.h"
      include "cons.h"
      include "index.h"
      include "strt.h"
      include "tlib.h"
      include "unit.h"
      include "sechis.h"
      include "amie.h"
      real :: wall_time
C     ****                   SET UP ADDRESS FOR RETURN OF CONTROL
C     ****                   IN THE EVENT OF AN ERROR EXIT
C     ****                   INITIALIZE THE MODEL
C     ****
C     ****
C     ****     COPY IPROCC TO IPROC IN COMMON/STRT/
C     ****
      call wtimer(wall_time)
!
      IPROC = IPROCC
C     ****     INITIALIZE GKS
C     ****
      IF(IPROC.EQ.0)CALL OPNGKS
      CALL START
C     ****
C     ****     IF IPROC.EQ.1, ALLOCATE SPACE FOR HISTORY FIELDS
C     ****
      IF(IPROC.EQ.1)CALL ALOCBF
      GO TO 20
C     ****                   ADVANCE THE MODEL IN TIME
   10 CALL ADVNCE
C     ****     CHECK FOR HISTORY FILE WRITE
!     write(6,"('FOGCM after ADVNCE: ihis=',i3,' ihissech=',i3,
!    +  ' isav=',i3,' isavsech=',i3)") ihis,ihissech,isav,isavsech
 20   if (ihis.ne.0.and.ihissech.ne.0) goto 30
      IF (IPROC.LE.0) THEN
        if (ihis.eq.0) call output(0)           ! write a full restart history
        if (ihissech.eq.0) call output(1)       ! write a secondary history
      ELSE
        UTHR = AMOD(FLOAT(ITER)*C(4),86400.) / 3600.
        write(6,"('FOGCM: uthr=',f7.3,' mtime=',3i4)") uthr,mtime
      ENDIF
C     ****     CHECK FOR ERROR IN OUTPUT
      IF(NERR.EQ.0)GO TO 30
      NERR=0
      if (iproc.le.0) then
        if (isav.eq.0) call wtsave(0)
        if (isavsech.eq.0) call wtsave(1)
      endif
C     ****
C     ****     CLOSE UNITS 8, 9, 16, GKS
C     ****
      IF(IPROC.EQ.0)CALL CLSGKS
      CLOSE(UNIT=8,IOSTAT=IOS1,STATUS='DELETE',ERR=7890)
 7890 CONTINUE
      CLOSE(UNIT=9,IOSTAT=IOS2,STATUS='DELETE',ERR=8901)
 8901 CONTINUE
      CLOSE(UNIT=17,IOSTAT=IOS3,STATUS='DELETE',ERR=9012)
 9012 CONTINUE
      IOS4 = 0
      IF(IAMIE.EQ.1)THEN
        CLOSE(UNIT=16,IOSTAT=IOS4,STATUS='DELETE',ERR=1234)
 1234   CONTINUE
      ENDIF
      IF(IOS1+IOS2+IOS3+IOS4.NE.0)THEN
        WRITE(6,6543)IOS1,IOS2,IOS3,IOS4
 6543   FORMAT(* START --- PROBLEM CLOSING UNITS 8,9,15 IOS=*,4I5)
        STOP
      ENDIF
      RETURN
C     ****     CHECK FOR SAVE TAPE WRITE
 30   if (isav.ne.0.and.isavsech.ne.0) goto 40
      if (iproc.le.0) then
        if (isav.eq.0) call wtsave(0)
        if (isavsech.eq.0) call wtsave(1)
      endif
 40   if (iter.lt.nstp) goto 10                 ! do another advnce call
      if (iend.eq.2) then
        nstp = nnstp(2)
        mhis = mmhis(2)
        ihis = mhis
        ihissech = mhissech
        iend = 1
        goto 10
      endif
c
c 5/98: secondary histories do not check for iend==2.
      IF(IEND.EQ.2) THEN
          NSTP=NNSTP(2)
          MHIS=MMHIS(2)
          IHIS=MHIS
          IEND=1
          GO TO 10
      END IF
      WRITE(6,100)ITER
  100 FORMAT(*1NORMAL EXIT AT ITER=*I6)
C     ****
C     ****     CLOSE UNITS 8, 9, 16, GKS
C     ****
      IF(IPROC.EQ.0)CALL CLSGKS
      CLOSE(UNIT=8,IOSTAT=IOS1,STATUS='DELETE',ERR=9876)
 9876 CONTINUE
      CLOSE(UNIT=9,IOSTAT=IOS2,STATUS='DELETE',ERR=8765)
 8765 CONTINUE
      CLOSE(UNIT=17,IOSTAT=IOS3,STATUS='DELETE',ERR=7654)
 7654 CONTINUE
      IOS4 = 0
      IF(IAMIE.EQ.1)THEN
        CLOSE(UNIT=16,IOSTAT=IOS4,STATUS='DELETE',ERR=2345)
 2345   CONTINUE
      ENDIF
      IF(IOS1+IOS2+IOS3+IOS4.NE.0)THEN
        WRITE(6,6543)IOS1,IOS2,IOS3,IOS4
        STOP
      ENDIF
      RETURN
      END
C