	PROGRAM SFCNTR
C************************************************************************
C* This program plots surface data on a map.				*
C*									*
C* Log:									*
C* I. Graffman/RDS	 8/87	GEMPAK4					*
C* M. desJardins/GSFC	 6/88	Rewrote					*
C* G. Huffman/GSC	 1/89	Note for SCALE in [-100,-5],[5,100],	*
C*				filter in N coord.			*
C* M. desJardins/GSFC	11/89	Added conditions and STIM		*
C* M. desJardins/GSFC	 1/90	Add SKPMIS				*
C* S. Schotz/GSC	 4/90   Added capability to plot weather/cloud	*
C*                              symbols, also cleaned up somewhat	*
C* S. Schotz/GSC	 5/90	Will now plot markers when all other	*
C*				parameters are not plotted		*
C* M. desJardins/GSFC	 7/90	Added LATLON				*
C* S. Schotz/GSC	 8/90	Removed scale added display of 		*
C*				conditions in title, and screen output	*
C* J. Whistler/SSAI	 7/91	Moved parm cond. filter out of SFMPLT	*
C*				and placed before station filter	*
C* S. Jacobs/SSAI	10/91	Changed PANEL to *48			*
C* S. Jacobs/SSAI	10/91	Added capability to plot certain	*
C*				stations before filtering.		*
C* M. desJardins/NMC	10/91	Check for state name; list of stations	*
C* K. Brill/NMC		11/91	Add John Nielsen's flexible filter and	*
C*				changes for removing WIND input parm    *
C*				and getting barb/arrow info from SFPARM *
C* S. Jacobs/EAI	 6/92	Fixed call to SFMPLT to send lat/lon	*
C* S. Jacobs/EAI	10/92	Fixed typo in call to PC_SSTN		*
C* S. Jacobs/EAI	11/92	Added call to GMESG and 'shrttl'	*
C* S. Jacobs/NMC         3/94   Added satellite display routines        *
C* L. Williams/EAI	 3/94	Clean up declarations of user input	*
C*				variables				*
C* S. Jacobs/NMC	 6/94	DEVICE*24 --> *72			*
C* S. Jacobs/NMC	 6/94	COLORS*24 --> *72			*
C* L. Williams/EAI	 7/94	Removed call to SFMUPD and added shrttl *
C*				to the user input variables		*
C* S. Jacobs/NMC	 8/94	Added GSTANM, GSPLOT for animation	*
C* P. Bruehl/Unidata	 8/94	Added logical first, prompt only once	*
C* J. Cowie/COMET	 8/94	Modified for multiple sat image looping	*
C* M. desJardins/NMC	 8/94	Added ST_FLST				*
C* L. Williams/EAI	 9/94	Grouped title code together		*
C* S. Jacobs/NMC	 9/94	Moved the title plotting to the end	*
C* S. Jacobs/NMC	10/94	Added GR_MTTL to create the title	*
C* J. Cowie/COMET	 1/95	Added SATFIL and RADFIL			*
C* S. Jacobs/NMC	 2/95	Moved IN_TEXT to before setting proj	*
C* J. Cowie/COMET	 8/95	Change GSATIM to IM_DROP, add IM_LUTF, 	*
C*				use idrpfl				*
C* D. Plummer/NCEP	11/95	Added LUTFIL processing			*
C* D. Keiser/GSC	12/95	Added STNPLT as a parameter		*
C* D. Keiser/GSC	 8/96	Added FL_MFIL to search for file type	*
C* K. Tyle/GSC		 8/96	Added ER_WMSG call after FL_MFIL call	*
C* S. Jacobs/NCEP	 1/97	Changed the order of IM_DROP & IM_LUTF	*
C* S. Maxwell/GSC	 3/97	Added call to TB_PARM			*
C* S. Maxwell/GSC	 3/97	Removed marker and skmis		*
C* S. Maxwell/GSC        7/97   Increased input character length        *
C* D. Kidwell/NCEP	 2/98	Added color coding capability           *
C* A. Hardy/GSC		 1/99	Added grouping calls for station models *
C* A. Hardy/GSC		 2/99	Increased variable parms from 72 to 128 *
C* S. Jacobs/NCEP	 3/99	Changed calls to SFMPRM and SFMPLT	*
C* A. Hardy/GSC		 3/99	Added priority parameter to PC_SSTN     *
C* A. Hardy/GSC		 3/99	Added priority parameter to SF_SNXT     *
C* A. Hardy/GSC		 3/99	Removed ispri = 0			*
C* S. Jacobs/NCEP	 3/99	Changed chd from 8 char to 12 char	*
C* S. Jacobs/NCEP	 3/99	Added Med Range station model group type*
C* S. Jacobs/NCEP	 5/99	Added the CLRBAR parameter		*
C* S. Chiswell/Unidata   2/02   Added IMBAR                             *
C* S. Chiswell/Unidata	10/05	Updated OA_BARN call for bounds block	*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C*
	CHARACTER	sffile*(LLMXLN), area*(LLMXLN), garea*(LLMXLN),
     +			sfparm*(LLMXLN), dattim*(LLMXLN),
     +			colors*(LLMXLN), map*(LLMXLN), title*(LLMXLN),
     +			device*(LLMXLN), filter*(LLMXLN), proj*(LLMXLN),
     +			panel*(LLMXLN), text*(LLMXLN), latlon*(LLMXLN),
     +			shrttl*(LLMXLN), satfil*(LLMXLN),
     +			radfil*(LLMXLN), lutfil*(LLMXLN),
     +			stnplt*(LLMXLN), clrbar*(LLMXLN),
     +			imcbar*(LLMXLN),
     +			cntrprm*(LLMXLN), ucntrprm*(LLMXLN),nproj*72,
     +			gamma*(LLMXLN), linetyp*(LLMXLN), contur*(LLMXLN),
     +			weight*(LLMXLN), cnpass*(LLMXLN), cintc*(LLMXLN)
C*
	LOGICAL		clear
C*
	CHARACTER	sffcur*72, arecur*48, datcur*48, filnam*72
	CHARACTER 	pmdset (MMPARM)*4, parms*128, colrs*(LLMXLN)
	CHARACTER	prmlst (MMPARM)*4, times (LLMXTM)*15
	CHARACTER	tstn*8, sta*8, ttlstr*48, ttt*72
        CHARACTER       prcons (MMPARM)*16, chd (MMPARM)*12
	CHARACTER	area1*48, area2*48, ttlinp*72, shrtin*72
	CHARACTER	imgfls(MXLOOP)*132, uprj*72, endflg*1
	CHARACTER	clbl(LLCLEV)*24
	INTEGER		icolor (MMPARM), iscale (MMPARM)
	INTEGER		numccc (MMPARM), icclrs (MMPARM*LLCLEV)
	INTEGER		icrprm (MMPARM)
	LOGICAL		respnd, done, proces, newfil, chrflg (MMPARM)
	LOGICAL		wndflg, plot
	REAL		offset (4), sxplt (LLSTFL), outd (MMPARM)
	REAL		syplt (LLSTFL), data (MMPARM)
	REAL		ccvals (MMPARM*LLCLEV)
	REAL		clats(LLSTFL),clons(LLSTFL),convals(1,LLSTFL),
     +                  srow(LLSTFL),scol(LLSTFL)
	LOGICAL		 stninb(LLSTFL), gpinb (LLMXGD)
	REAL		gelt(LLMXGD),geln(LLMXGD),coslt(LLMXGD),
     +			cosstn(LLSTFL),rgrid(1,LLMXGD)
	REAL		cints(LLCLEV), gltln(4), sinvls(1,LLSTFL)
	REAL		grltln(4), eltln(4), dltln(4), rms(1)
	INTEGER		ncvals, iextend(4), isn(1)
	INTEGER		icolr(LLCLEV),itype(LLCLEV),iwidth(LLCLEV),
     +			ilabel(LLCLEV)
	INTEGER		kx, ky, kex, key
	REAL		deltax, deltay
	CHARACTER	extnd*10
	LOGICAL		first, scflag
C------------------------------------------------------------------------
C--------1---------2---------3---------4---------5---------6---------7--
	CALL IP_INIT  ( respnd, iperr )
	IF  ( iperr .eq. 0 )  THEN
	    CALL GG_INIT  ( 1, iperr )
	END IF
	IF  ( iperr .eq. 0 )  THEN
	    done = .false.
	  ELSE
	    done = .true.
	END IF
	CALL IP_IDNT  ( 'SFCNTR', ier )
C
	DO WHILE  ( .not. done )
	    CALL SFMINP  ( sffile, area, garea, sfparm, dattim, colors,
     +			   map, title, clear, device, proj, filter,
     +			   panel, text, latlon, satfil, radfil,
     +			   lutfil, stnplt, clrbar, cntrprm, gamma,
     +			   linetyp, contur, weight, cnpass, cintc,
     +			   imcbar, iperr )
	    IF  ( iperr .lt. 0 )  THEN
	        done = .true.
                proces = .false.
	      ELSE
	        proces = .true.
            END IF
C
C*	    Set up device and projection.
C
            IF ( proces ) THEN
                CALL GG_SDEV  ( device, iret )
	        IF  ( iret .ne. 0 )  proces = .false.
C
C*		Set text.
C
                CALL IN_TEXT ( text, ier )
C
C*		If projection=SAT or RAD, see if multiple image files
C*		have been specified.
C
		CALL ST_LCUC ( proj, uprj, ier )
                IF  ( uprj (1:3) .eq. 'SAT' )  THEN
	            CALL ST_FLST  ( satfil, ';', ' ', MXLOOP, imgfls,
     +                             numimg, ier )
                ELSE IF  ( uprj (1:3) .eq. 'RAD' )  THEN
	            CALL ST_FLST  ( radfil, ';', ' ', MXLOOP, imgfls,
     +                             numimg, ier )
	        END IF
C
C*		Set map projection
C
		CALL GG_MAPS  ( proj, garea, imgfls (1), idrpfl, iret )
   	        IF  ( iret .ne. 0 )  proces = .false.
C
C*	        Process filename.
C
		CALL FL_MFIL ( sffile, ' ', filnam, iret )
		IF ( iret .ne. 0 ) CALL ER_WMSG ( 'FL', iret, ' ', ier )
	        CALL SFMFIL  ( filnam, sffcur, iflno, newfil, pmdset,
     +			       npmdst, iret )
	        IF  ( iret .ne. 0 )  proces = .false.
            END IF
C
C*          Process text, title, filter and parms.
C
	    IF  ( proces )  THEN
		CALL IN_FILT ( filter, filtfc, ier )
C
		CALL TB_PARM ( sfparm, parms, colrs, iret )
		IF ( iret .lt. 0 ) THEN
		   CALL ER_WMSG ( 'TB', iret, ' ', ier )
		   proces = .false.
		ELSE IF ( iret .eq. 2 ) THEN
	  	   parms = sfparm
		   colrs = colors
		ELSE
		   IF ( colors .ne. ' ' ) colrs = colors
		END IF
	    END IF
C
	    IF  ( proces )  THEN
C
C*		Process parameter names and colors.
C
		CALL SFMPRM  ( parms, pmdset, npmdst, colrs,
     +			       prmlst, chrflg, ncprm, prcons, wndflg,
     +			       icolor, ccvals, icclrs, numccc, icrprm,
     +			       iaddcl, endflg, ier )
		if(cntrprm .ne. ' ') then
                   CALL ST_LCUC (cntrprm, ucntrprm, ier)
		   CALL ST_FIND (ucntrprm, prmlst, ncprm, icntrpos, ier )
		else
		   icntrpos = 0
		end if
C
C*		Determine whether any data will be plotted.
C
		IF (ncprm .eq. 0) THEN
	           plot = .false.
		  ELSE
	           plot = .true.
		END IF
C
C*              Get offsets for filtering.
C
		IF  ( ( filtfc .ne. 0. ) .and. plot )
     +             CALL SFMCOF ( ncprm - iaddcl, prmlst, wndflg,
     +			    	 filtfc, offset, ier )
C
C*		Take care of the special case of plotting a list of
C*		stations before plotting an area with the filter on.
C
		ipos2 = INDEX ( area, '/' )
		IF  ( area(1:1) .eq. '@' .and. ( ipos2 .gt. 4 ) ) THEN
		    area1 = area(:ipos2-1)
		    area2 = area(ipos2+1:)
		    iloop = 1
		  ELSE
		    area1 = area
		    iloop = 2
		END IF
C
C*	        Set area and get times to be processed.
C
		CALL LC_UARE  ( area1, newfil, iflno, arecur, tstn,
     +		  	        ier )
		IF  ( ier .ne. 0 )  proces = .false.
C*
		CALL SFMDAT  ( dattim, iflno, newfil,
     +			       datcur, ntime, times,  ier )
		IF  ( ier .ne. 0 )  proces = .false.
	    END IF
C
C*	    Begin processing if inputs are ok.
C
	    itime = 1
C
C*	    Plot all times even if there are no images.
C*          Loop over times.
C
 	    DO WHILE  ( proces )
C
C*	      Set the current pixmap.
C*	      If this is the first time, go to the first pixmap.
C*	      If it is not the first time, go to the next pixmap.
C
	      IF  ( itime .eq. 1 )  THEN
		  CALL GSTANM ( iret )
		  first = .true.
	        ELSE
		  CALL GSPLOT ( iret )
		  first = .false.
C
C*		  Set the map projection for each image
C
		  IF  ( uprj (1:3) .eq. 'SAT' .or.
     +			uprj (1:3) .eq. 'RAD' )
     +			CALL GG_MAPS  ( proj, garea, imgfls (itime),
     +				        idrpfl, iret )
	       END IF
	       nplot = 0
	       ncvals = 0
	       CALL SF_STIM  ( iflno, times (itime), ier )
C
C* 	       Give the user a chance to exit
C
	       IF ( first )
     +		   CALL SFMOPT ( sffcur, times (itime), device,
     +				 proj, area, garea, ncprm, prcons,
     +				 icolor, map, title, clear, filtfc,
     +                           itime, panel, ccvals, icclrs, numccc,
     +                           icrprm, iaddcl, iopt )
	       IF  ( iopt .lt. 0 )  proces = .false.
C
C*	       Process clear, define panel, set up filtering and
C*	       draw map.
C
	       IF  ( proces )  THEN
		  IF  ( clear )  CALL GCLEAR  ( iret )
		  CALL GG_PANL  ( panel, ier )
C
C*		  Apply LUT file
C
		  IF ( itime .eq. 1 ) CALL IM_LUTF ( lutfil, ier )
C
C*                Display satellite image, if desired.
C
                  IF ( idrpfl .eq. 1 .or.
     +		     ( idrpfl .eq. 0 .and. clear ) ) THEN
     			CALL IM_DROP ( iret)
     			CALL IM_CBAR ( imcbar, iret )
		  END IF
C
C*		  Draw map, lat/lon lines, and station ID/marker.
C
	          CALL GG_MAP  ( map, ier )
		  CALL GG_LTLN ( latlon, ier )
		  CALL GG_SPLT ( stnplt, iret )
C
C*		   Intialize coordinate arrays for filtering.
C
	           IF  ( ( filtfc .ne. 0. ) .and. plot )  THEN
		       DO  m = 1, LLSTFL
			   sxplt (m) = RMISSD
		           syplt (m) = RMISSD
		       END DO
		   END IF
C
C*		   For special plotting, change the area on the
C*		   second time through.
C
		   DO  lll = iloop, 2
		     IF  ( ( lll .eq. 2 ) .and. ( iloop .eq. 1 ) )
     +							 THEN
		       CALL LC_UARE  ( area2, newfil, iflno,
     +		      		       arecur, tstn, ier )
		       IF  ( ier .ne. 0 )  plot = .false.
		     END IF
C
C*		     Station loop.
C
		     iout = 0
		     DO  WHILE  ( plot .and. (iout .eq. 0) )
			 CALL SF_SNXT ( iflno, sta, id, slat,
     +					slon, selv, ispri, iout )
	                 IF  ( iout .eq. 0 )  THEN
C
C*			     Get the data.
C
			     CALL SF_RDAT ( iflno, data, ihhmm, ier )
C
C*			     Check for missing data and filter.
C
		             IF  ( ier .eq. 0 ) THEN
				 CALL PC_SSTN ( sta, id, slat, slon,
     +						selv, ispri, ihhmm, 1,
     +						ier )
				 CALL PC_CMVS ( 0., 0, data,
     +						outd, chd, ier )
			     END IF
C*
		             IF  ( ier .eq. 0 ) THEN
C
C*				Convert to plot coordinates.
C
                                CALL GTRANS  ( 'M', 'P', 1, slat, slon,
     +					        sx, sy, ier )
C
C*			        Filter, if requested.
C
			        IF  ( ( filtfc .ne. 0. ) .and.
     +				      ( lll .eq. 2 ) ) THEN
				   CALL SFMOVR  ( sx, sy, sxplt, syplt,
     +						  nplot, offset, ier )
C
C*				   Save x/y for no overlap.
C
				   IF  ( ier .eq. 0 )  THEN
				      nplot = nplot + 1
				      sxplt (nplot) = sx
				      syplt (nplot) = sy
				   END IF
				 ELSE IF  ( ( filtfc .ne. 0. ) ) THEN
				   nplot = nplot + 1
				   sxplt (nplot) = sx
				   syplt (nplot) = sy
		                 END IF
			     END IF
C
C*    	                     Plot if we are ok to here.
C
	                     IF  ( ier .eq. 0 )  THEN
C
C*				Group a "normal" station model as
C*				group type 10. The Medium Range AFOS
C*				products are group type 11.
C
				CALL ST_FIND ( 'TPFC', prmlst, ncprm,
     +						ipos, ier )
				IF  ( ipos .eq. 0 )  THEN
				    igroup = 10
				  ELSE
				    igroup = 11
				END IF
C
				CALL GSGRP  ( igroup, iret )
C
                                if(icntrpos .ne. 0) then
                                   ncvals = ncvals + 1
                                   clats(ncvals) = slat
                                   clons(ncvals) = slon
                                   convals(1,ncvals) = outd(icntrpos)
                                endif
				CALL SFMPLT ( icolor, sx, sy, slat,
     +					      slon, chrflg, prmlst,
     +					      ncprm, outd, chd,
     +					      ccvals, icclrs, numccc,
     +					      icrprm, endflg, ier )
C
				CALL GEGRP  ( iret )
	                     END IF
			 END IF
	             END DO
		 END DO

C
C*               See if we need to contour
C
		 if(ncvals .gt. 0) then
		     CALL GQMPRJ(nproj, rang1, rang2, rang3,
     +			    rlatll, rlonll, rlatur, rlonur,ier)
C
C*		     Get Station Spacing
C
		     gltln(1) = rlatll
		     gltln(2) = rlonll
		     gltln(3) = rlatur
		     gltln(4) = rlonur
		     CALL OAGSPC(gltln,clats,clons,ncvals,dscomp,
     +					dsunif,ier)
		     deltan = ( dscomp + dsunif ) / 2.
		     deltay = deltan / 2.
		     deltax = deltay / COS ( ( (gltln(1) + gltln(3) )
     +					/ 2. ) * DTR )
		     deltan = FLOAT ( NINT ( deltan * 100. )) / 100.
		     deltay = FLOAT ( NINT ( deltay * 100. )) / 100.
		     deltax = FLOAT ( NINT ( deltax * 100. )) / 100.
C
C*		     set extend area and base projection
C
		     IF  (( uprj (1:3) .eq. 'SAT' ) .or.
     +				( uprj (1:3) .eq. 'RAD' )) THEN
			   extnd = '0;0;0;0'
			   nproj = 'CED'
		     ELSE
			   extnd = ' '
		     ENDIF

		     CALL OAGAGN(gltln,extnd,deltax,deltay,.false.,
     +			   grltln,eltln,iextend,kx,ky,dltln,ier)

		     write(*,*) 'Using ',kx,'x',ky,' grid.'

		     kex = kx + iextend(1) + iextend(2)
		     key = ky + iextend(3) + iextend(4)

 		     CALL GSGPRJ(nproj,rang1,rang2,rang3,kx,ky,
     +                     rlatll, rlonll, rlatur, rlonur,ier)

		     CALL OA_LTLN(kex,key,iextend,gelt,geln,coslt,
     +					ier)
		     do i=1,ncvals
			   cosstn(i) = cos(clats(i) * DTR)
		     end do
		     CALL OA_BOXC(clats,clons,ncvals,iextend,srow,
     +					scol,ier)
                     do i=1,kex*key
			   rgrid(1,i) = 0
C
C*			   all grid points unblocked
C
		           gpinb (i) = .FALSE.
                     end do
		     CALL ST_C2R(gamma,1,rgamma,ifnd,ier)
                     if(ier .ne. 0) then
                         rgamma = .3
                         write(*,*) 'GAMMA defaulting to ',rgamma
                     else
                         if(rgamma.lt.0) rgamma = 0
                         if(rgamma.gt.1) rgamma = 1
		     endif
		     CALL ST_C2R(weight,1,rsearch,ifnd,ier)
                     if(ier .ne. 0) then
                           rsearch = 20.
                           write(*,*) 'WEIGHT defaulting to ',rsearch
                     else
                           if(rsearch.le.0) rsearch = 0.01
                           if(rsearch.gt.50) rsearch = 50.
		     endif
		     kexy = kex*key
		     CALL OA_WFSR(deltan,rsearch,rweight,srad,ier)
		     do i=1,ncvals
			   sinvls(1,i) = convals(1,i)
C
C*			   No blocking for any stations
C
			   stninb (i) = .FALSE.
		     end do
		     CALL ST_C2I(cnpass,1,ipass,ifnd,ier)
                     if(ier .ne. 0) then
                           ipass = 2
                           write(*,*) 'NPASS defaulting to ',ipass
                     else
                           if(ipass.lt.1) ipass = 1
                           if(ipass.gt.5) ipass = 5
		     endif

                     do npass=1,ipass
			   if(npass .eq. 2) then
			      rweight = rweight * rgamma
			      srad = srad * rgamma
			   endif
			   CALL OA_BARN(1,rweight,srad,kexy,ncvals,
     +			             sinvls,clats,clons,gelt,geln,
     +				     coslt,cosstn,.TRUE.,.FALSE.,
     +				     gpinb, stninb,
     +				     isn, rgrid, ier)
			   CALL OA_SINT(1,ncvals,convals,srow,scol,
     +				kex, key, rgrid, iextend, sinvls, rms,
     +				isn, ier)
C--------1---------2---------3---------4---------5---------6---------7--
			   write(*,*) 'Barnes Pass: ',npass
                           write(*,*) 'RMS: ',rms,
     +					' Number of stations: ',isn
			   write(*,*) ' '
		     end do

		     gmax = RMISSD
		     gmin = RMISSD
		     do i=1,kex*key
			   if(rgrid(1,i).ne.RMISSD) then
                              if(gmax .eq. RMISSD) then
                                 gmax = rgrid(1,i)
                              else if (rgrid(1,i) .gt. gmax) then
			         gmax = rgrid(1,i)
			      endif
                              if(gmin .eq. RMISSD) then
                                 gmin = rgrid(1,i)
                              else if (rgrid(1,i) .lt. gmin) then
			         gmin = rgrid(1,i)
			      endif
			   endif
                     end do
		     CALL IN_INTC(cintc, gmin, gmax, cints, ncint, clbl,
     +				crint, cmin, cmax, ier)
		     CALL IN_LINE(linetyp,cints,ncint,
     +				     icolr,itype,iwidth,ilabel,
     +                               smooth,rfilter,scflag,ier)
C
C*		     Check for duplicate contours & sort contours
C
		     CALL GR_NLEV ( ncint, cints, clbl, icolr, itype,
     +                               iwidth, ilabel, iret )
C
		     CALL IN_CONT( contur, ier )
		     if(smooth .ne. 0.0) then
			   CALL GSSMTH ( 2, smooth, ier )
                     END IF
                     CALL GSRDUC ( rfilter, ier )
		     CALL GCLGRN(kex,key,rgrid,-iextend(1), -iextend(2),
     +			0, ncint, cints, clbl, icolr, itype,
     +				iwidth, ilabel, scflag, ier)
		     IF  ( smooth .ne. 0.0 )  THEN
                            CALL GSSMTH ( 0, 0.0, ier )
                     END IF
		     CALL GSRDUC ( 0.0, ier )
		  end if
C
C*		     Draw color bar for first color-coded parameter.
C
		  ip = 1
		  DO WHILE ( ip .le. ncprm )
			 IF ( icolor (ip) .eq. (-1) ) THEN
			     CALL GG_CBAR ( clrbar, numccc (1 ) - 1,
     +					    ccvals, icclrs, ier )
			     ip = ncprm + 1
			   ELSE
			     ip = ip + 1
			 END IF
		  END DO
C
C*		     Create and draw the title.
C
		  ipbar = INDEX ( title, '|' )
		  IF  ( ipbar .ne. 0 )  THEN
			shrtin = title ( ipbar+1: )
			IF  ( ipbar .eq. 1 )  THEN
			    ttlinp = ' '
			ELSE
			    ttlinp = title ( :ipbar-1 )
			END IF
		  ELSE
			shrtin = ' '
			ttlinp = title
		  END IF
C
C*		     Create the title string.
C
		  CALL IN_TITL ( ttlinp, -3, ititl, linttl,
     +				    ttlstr, ier )
		  ncttl = ncprm - iaddcl
		  DO ii = 1, ncttl
			iscale (ii) = 0
		  END DO
		  IF  ( ititl .gt. 0 )  THEN
			CALL GR_MTTL  ( ttlstr, '^ _', .false.,
     +					times (itime), ' ', .false.,
     +					0, -1, 0, ncttl, prcons,
     +					iscale, ' ', ttt, ier )
			CALL GSCOLR  ( ititl, ier )
			CALL GG_WSTR ( ttt, linttl, ier )
		  END IF
C
C*		     Create the short title string.
C
		  IF  ( clear )  THEN
			CALL GR_MTTL  ( shrtin, 'SURFACE ^ #', .true.,
     +					times (itime), ' ', .false.,
     +					0, -1, 0, ncttl, prcons,
     +					iscale, area, shrttl, ier )
			CALL GMESG ( shrttl, ier )
		  END IF
C
C*		     Flush the graphics buffer.
C
	         CALL GEPLOT  ( iret )
		 itime = itime + 1
		 IF  ( itime .gt. ntime ) proces = .false.
	     END IF
	   END DO
	   CALL GENANM ( iret )
	   CALL IP_DYNM  ( done, iret )
	END DO
C*
	IF  ( iperr .ne. 0 )  CALL ER_WMSG  ( 'SFMAP', iperr, ' ', ier )
	CALL GENDP  ( 0, iret )
	CALL IP_EXIT  ( iret )
C*
	END


program pcmdisst
!------------------------------------------------------------------------------------
!
! Purpose: Wrapper program for routines (provided by Karl Taylor of PCMDI) which modify
!          mid-month values of SST and ice concentration to preserve monthly means upon
!          linear time interpolation.
!
! Method: Read in a namelist containing the relevant variables.  Check for validity,
!         then call driving subroutine.
!
!------------------------------------------------------------------------------------
   implicit none

   include 'netcdf.inc'

   integer :: mon1 = -1           ! start month of period of interest plus buffer
   integer :: iyr1 = -1           ! start year of period of interest plus buffer
   integer :: monn = -1           ! end month of period of interest plus buffer
   integer :: iyrn = -1           ! end year of period of interest plus buffer
   integer :: mon1rd = -1         ! start month to read from input data
   integer :: iyr1rd = -1         ! start year to read from input data
   integer :: monnrd = -1         ! end month to read from input data
   integer :: iyrnrd = -1         ! end year to read from input data
   integer :: mon1clm = -1        ! start month to use for climatology
   integer :: iyr1clm = -1        ! start year to use for climatology
   integer :: monnclm = -1        ! end month to use for climatology
   integer :: iyrnclm = -1        ! end year to use for climatology
   integer :: nlat = -1           ! number of latitudes (e.g. 64 for typical T42)
   integer :: nlon = -1           ! number of longitudes (e.g. 128 for typical T42)
   integer :: mon1out = -1        ! start month written to output file (default mon1rd)
   integer :: iyr1out = -1        ! start year written to output file (default iyr1rd)
   integer :: monnout = -1        ! end month written to output file (default monnrd)
   integer :: iyrnout = -1        ! end year written to output file (default iyrnrd)
   integer :: nmon                ! total number of months of period of interest plus buffer

   logical :: oldttcalc = .false. ! true => bfb agreement with original code

   character(len=120) :: infil      = ' ' ! input filename.
   character(len=120) :: outfilclim = ' ' ! output climatology file
   character(len=120) :: outfilamip = ' ' ! output AMIP-style file
   character(len=256) :: string           ! temporary character variable

   character(len=256) :: arg                 ! cmd line argument
   character(len=512) :: cmdline             ! input command line
   character(len=19)  :: cur_timestamp
   character(len=1024) :: prev_history = ' ' ! history attribute from input file
   character(len=1024) :: history = ' '      ! history attribute for output files
!
! netcdf info
!
   integer :: ncidin = -1         ! input file handle
   integer :: londimid = -1       ! longitude dimension id
   integer :: latdimid = -1       ! latitude dimension id
!
! Cmd line
!
   integer, external :: iargc
   integer           :: n, nargs
!
! Namelist
!
   namelist /cntlvars/ mon1, iyr1, monn, iyrn, mon1rd, iyr1rd, monnrd, iyrnrd, &
                       mon1clm, iyr1clm, monnclm, iyrnclm, mon1out, &
                       iyr1out, monnout, iyrnout, oldttcalc
!
! Read namelist
!
   read (5,cntlvars)
!
! Check that all required input items were specified in the namelist
!
   call verify_input (mon1, 'mon1', 'start month of period of interest plus buffer')
   call verify_input (iyr1, 'iyr1', 'start year of period of interest plus buffer')
   call verify_input (monn, 'monn', 'end month of period of interest plus buffer')
   call verify_input (iyrn, 'iyrn', 'end year of period of interest plus buffer')
   call verify_input (mon1rd, 'mon1rd', 'start month of input data')
   call verify_input (iyr1rd, 'iyr1rd', 'start year of input data')
   call verify_input (monnrd, 'monnrd', 'end month of input data')
   call verify_input (iyrnrd, 'iyrnrd', 'end year of input data')
   call verify_input (mon1clm, 'mon1clm', 'start month of output climatology')
   call verify_input (iyr1clm, 'iyr1clm', 'start year of output climatology')
   call verify_input (monnclm, 'monnclm', 'end month of output climatology')
   call verify_input (iyrnclm, 'iyrnclm', 'end year of output climatology')
!
! Check that all specified input values are valid
!
   call verify_monthindx (mon1, 'mon1')
   call verify_monthindx (monn, 'monn')
   call verify_monthindx (mon1rd, 'mon1rd')
   call verify_monthindx (monnrd, 'monnrd')
   call verify_monthindx (mon1clm, 'mon1clm')
   call verify_monthindx (monnclm, 'monnclm')
!
! Check that input dates are valid with respect to each other
!
   if ((mon1clm + 12*iyr1clm) < (mon1rd + 12*iyr1rd)) then
      write(6,*)'mon1clm, iyr1clm=', mon1clm, iyr1clm
      write(6,*)'mon1rd,  iyr1rd= ', mon1rd, iyr1rd
      call err_exit ('Dates for data to be read must bracket climatology')
   end if

   if (mon1rd + 12*iyr1rd > monnrd + 12*(iyrnrd-1)) then
      write(6,*)'mon1rd, iyr1rd=', mon1rd, iyr1rd
      write(6,*)'monnrd, iyrnrd=', monnrd, iyrnrd
      call err_exit ('must read at least 1 year of data total')
   end if

   if ((monnclm + 12*iyrnclm) > (monnrd + 12*iyrnrd)) then
      write(6,*)'monnclm, iyrnclm=', monnclm, iyrnclm
      write(6,*)'monnrd,  iyrnrd= ', monnrd, iyrnrd
      call err_exit ('End date for climatology exceeds end date of data to be read')
   end if

   if (iyr1rd > iyrnrd .or. iyr1rd == iyrnrd .and. mon1rd > mon1rd) then
      write(6,*)'mon1rd, iyr1rd=', mon1rd, iyr1rd
      write(6,*)'monnrd, iyrnrd=', monnrd, iyrnrd
      call err_exit ('Start date for input data exceeds end date')
   end if

   if (iyr1 > iyrn .or. iyr1 == iyrn .and. mon1 > monn) then
      write(6,*)'mon1, iyr1=', mon1, iyr1
      write(6,*)'monn, iyrn=', monn, iyrn
      call err_exit ('Start date for output data exceeds end date')
   end if

   if (.not. (monn == mon1-1 .or. mon1 == 1 .and. monn == 12)) then
      write(6,*)'mon1, monn=', mon1, monn
      call err_exit ('Period to be treated must be an integral number of years')
   end if

   if ((mon1 + 12*iyr1) > (mon1rd + 12*iyr1rd)) then
      write(6,*)'mon1,   iyr1=  ', mon1, iyr1
      write(6,*)'mon1rd, iyr1rd=', mon1rd, iyr1rd
      call err_exit ('Start date of data to be read must not preceed period of interest')
   end if

   if ((monn + 12*iyrn) < (monnrd + 12*iyrnrd)) then
      write(6,*)'monn,   iyrn=  ', monn, iyrn
      write(6,*)'monnrd, iyrnrd=', monnrd, iyrnrd
      call err_exit ('End date of data to be read must not follow period of interest')
   end if

   if (mod((monn+12-mon1+1),12) /= 0) then
      write(6,*)'mon1, monn=',mon1, monn
      string = 'error in time specifications: only integral number of yrs allowed'
      call err_exit (string)
   end if
!
! Ensure that climatology period is as expected (1982-2001).  To enable other
! averaging periods, just comment out the following bit of code
!
   if (mon1clm /= 1  .or. iyr1clm /= 1982 .or. &
       monnclm /= 12 .or. iyrnclm /= 2001) then
      write(6,*)'Climatological averaging period is not as expected (1982-2001)'
      write(6,*)'If you REALLY want to change the averaging period, delete the'
      write(6,*)'appropriate err_exit call from driver.f90'
      call err_exit ('pcmdisst')
   end if
!
! Calculate derived variables
!
   nmon = (iyrn - iyr1)*12 + (monn - mon1 + 1)

   if (monn - mon1 + 12*(iyrn - iyr1)+1 /= nmon) then
      string = 'error in time specifications: parameter nmon must be consistent with '// &
               'first and last months specified. Check nmon, mon1, iyr1, monn, iyrn'
      call err_exit (string)
   end if

   ! parse command line arguments, saving them to be written to history attribute
   nargs = iargc ()
   n = 1
   cmdline = 'bcgen '
   do while (n <= nargs)
      arg = ' '
      call getarg (n, arg)
      n = n + 1
      select case (arg)
      case ('-i')
         call getarg (n, arg)
         n = n + 1
         infil = arg
         cmdline = trim(cmdline) // ' -i ' // trim(infil)
      case ('-c')
         call getarg (n, arg)
         n = n + 1
         outfilclim = arg
         cmdline = trim(cmdline) // ' -c ' // trim(outfilclim)
      case ('-t')
         call getarg (n, arg)
         n = n + 1
         outfilamip = arg
         cmdline = trim(cmdline) // ' -t ' // trim(outfilamip)
      case default
         write (6,*) 'Argument ', arg,' is not known'
         call usage_exit (' ')
      end select
   end do

!
! Check required input character variables
!
   if (infil == ' ') then
      call usage_exit ('input file must be specified using -i command-line option')
   end if

   if (outfilclim == ' ') then
      call usage_exit ('output climatology file must be specified using -c command-line option')
   end if

   if (outfilamip == ' ') then
      call usage_exit ('output time series file must be specified using -t command-line option')
   end if
!
! Set defaults for unspecified variables
!
   if (mon1out == -1) mon1out = mon1rd
   if (iyr1out == -1) iyr1out = iyr1rd
   if (monnout == -1) monnout = monnrd
   if (iyrnout == -1) iyrnout = iyrnrd
!
! Check validity of output dates
!
   call verify_monthindx (mon1out, 'mon1out')
   call verify_monthindx (monnout, 'monnout')

   if (iyr1out > iyrnout .or. iyr1out == iyrnout .and. mon1out > mon1out) then
      call err_exit ('Start date for output exceeds end date')
   end if
!
! Calculate derived variables
!
   nmon = (iyrn - iyr1)*12 + (monn - mon1 + 1)
!
! Open input file and obtain grid size (nlon and nlat)
!
   call wrap_nf_open (infil, NF_NOWRITE, ncidin)
   call wrap_nf_inq_dimid (ncidin, 'lon', londimid)
   call wrap_nf_inq_dimid (ncidin, 'lat', latdimid)
   call wrap_nf_inq_dimlen (ncidin, londimid, nlon)
   call wrap_nf_inq_dimlen (ncidin, latdimid, nlat)
!
! Add to or define history attribute.
!
   if (nf_get_att_text (ncidin, NF_GLOBAL, 'history', prev_history) /= NF_NOERR) then
      write(6,*)'nf_get_att_text() failed for history attribute'
   end if

   call get_curr_timestamp(cur_timestamp)
   if (len_trim(prev_history) == 0) then
      history = cur_timestamp // ' ' // trim(cmdline)
   else
      history = trim(prev_history) // char(10) // cur_timestamp // ' ' // trim(cmdline)
   end if

   write(6,*)'Grid size is nlon,nlat=', nlon, nlat
!
! Call Karl's main program or the derivative code.  Either should give the same answers
!
   call bcgen (mon1, iyr1, monn, iyrn, mon1rd,                &
               iyr1rd, monnrd, iyrnrd, mon1clm, iyr1clm,      &
               monnclm, iyrnclm, nlat, nlon, mon1out,         &
               iyr1out, monnout, iyrnout, ncidin, outfilclim, &
               outfilamip, nmon, oldttcalc, history)
   write(6,*)'Done writing output files ', trim(outfilclim), ' and ', trim(outfilamip)
   stop 0
end program pcmdisst

subroutine verify_monthindx (indx, varname)
!------------------------------------------------------------------------------------
!
! Purpose: Check validity of input month index.
!
!------------------------------------------------------------------------------------
   implicit none
!
! Input arguments
!
   integer, intent(in) :: indx
   character(len=*), intent(in) :: varname

   if (indx < 1 .or. indx > 12) then
      write(6,*) varname, '=', indx, ' is an invalid month index'
      stop 999
   end if

   return
end subroutine verify_monthindx

subroutine err_exit (string)
!------------------------------------------------------------------------------------
!
! Purpose: Print an error message and exit
!
!------------------------------------------------------------------------------------
   implicit none
!
! Input arguments
!
   character(len=*), intent(in) :: string

   write(6,*) string
   stop 999
end subroutine err_exit

subroutine verify_input (ivar, ivarname, string)
!------------------------------------------------------------------------------------
!
! Purpose: Check that a required input variable was actually set.  If not, print an
!          error msg and exit.
!
! Method: All namelist input integer variables must have a non-negative value.  Since
!         they are initialized to -1, a check on < 0 effectively checks whether they
!         were correctly set in the namelist.
!------------------------------------------------------------------------------------
   implicit none
!
! Input arguments
!
   integer, intent(in) :: ivar
   character(len=*), intent(in) :: ivarname
   character(len=*), intent(in) :: string

   if (ivar < 0) then
      write(6,*) ivarname, ' must be set in the namelist to a non-negative value'
      write(6,*) 'verbose description of this variable: ', trim(string)
      stop 999
   end if

   return
end subroutine verify_input

subroutine usage_exit (arg)
   implicit none
   character*(*) arg

   if (arg /= ' ') write (6,*) arg
   write (6,*) 'Usage: bcgen -i infile -c climfile -t tsfile < namelist_file'
   write (6,*) '  -i file: input file'
   write (6,*) '  -c file: output climatology file'
   write (6,*) '  -t file: output time series file'
   stop 999
end subroutine usage_exit

subroutine get_curr_timestamp(time)
! return timestamp formatted as "YYYY-MM-DD HH:MM:SS"
   character(len=19), intent(out) :: time
   integer :: t(8)
   call date_and_time(values=t)
   write(time,'(i4,a,i2.2,a,i2.2,a,i2.2,a,i2.2,a,i2.2)') t(1),'-',t(2),'-',t(3),' ',&
                                                         t(5),':',t(6),':',t(7)
end subroutine get_curr_timestamp


*     ==================================================================
*
*      THIS PROGRAM EVALUATES THE BREIT-PAULI OPERATORS
*
*     ONE-ELECTRON OPERATOR
*     ELECTROSTATIC INTERACTION
*     SPIN-ORBIT INTERACTION
*     SPIN-OTHER-ORBIT INTERACTION
*     SPIN-SPIN INTERACTION
*
*       by C. Froese Fischer and G. Tachiev
*          Vanderbilt University
*          Nashville, TN 37235 USA
*          May, 1983
*
*       Modified for Gediminas g-angular structure
*       Modified for Unsorted version
*       Modified for restarting
*                               [Sep 1994]
*
*
*     ==================================================================
*
*       The PARAMETER values in this program define the following:
*               LSDIM - Number of coeffficients in a block
*               NTERMD- Maximum number of terms
*
*     ------------------------------------------------------------------
      PROGRAM Breit_Matrix
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      PARAMETER (NTERMD=31)
*
*
* >>>>>> mpi <<<<<<
      INCLUDE 'mpif.h'
      parameter (MAXPROC=9999)
      common /MPI/ myid, nprocs, ierr, istat(MPI_STATUS_SIZE)
      character*4 idstring
      character*128 startdir, permdir, tmpdir
      character*128 file_cint,file_ih,file_ico,file_clst,file_atomc
* >>>>>>     <<<<<<<

      CHARACTER*26 STRING,ATOMC,ATOML,ATOMJ,ATOMW,ATOMNEW
      CHARACTER QREL, QMASS
      COMMON/INFORM/IREAD,IWRITE,IOUT,ISC(8),ISCW

      CHARACTER*128 input
      EXTERNAL INITT
      logical REL
*
*     Set machine dependent unit numbers
*               IREAD - The unit number of standard input
*               IWRITE- The unit number of standard output
*               ISCW  - The unit number of standard error (screen)
*               iuc   - The unit number for the <name>.c file
*
      iread = 4
      IOUT = 8
      in = 5

      if (myid.eq.0) then
         ISCW = 0
         IWRITE = 6
      else
         iscw = 40
         iwrite = 40
      end if

      call MPI_INIT(ierr)
      call MPI_COMM_RANK(MPI_COMM_WORLD, myid, ierr)
      call MPI_COMM_SIZE(MPI_COMM_WORLD, nprocs, ierr)

      write(idstring,'(I4.4)') myid

      startdir = ' '; permdir = ' '; tmpdir = ' ';
      call mpi_work_dir(startdir, permdir, tmpdir)
      lenstart = LEN_TRIM (startdir) - 1
      lenperm = LEN_TRIM (permdir) - 1
      lentmp = LEN_TRIM (tmpdir) - 1

      if (myid == 0) then
        call inp_atom(ATOMC,ATOML,ATOMJ,ATOMW,ATOMNEW,
     :      REL,MASS,iscw,in)
      end if

      call MPI_BCAST(ATOMC,26,MPI_CHARACTER,0,MPI_COMM_WORLD,ierr);
      call MPI_BCAST(MASS,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr);
      call MPI_BCAST(REL,1,MPI_LOGICAL,0,MPI_COMM_WORLD,ierr);

      file_cint  = tmpdir(1:lentmp)//'/cint.lst.'//idstring
      file_ih    = tmpdir(1:lentmp)//'/ih.lst.'//idstring
      file_ico   = tmpdir(1:lentmp)//'/ico.lst.'//idstring
      file_clst  = tmpdir(1:lentmp)//'/c.lst.'//idstring
      file_atomc = permdir(1:lenperm)//'/'//atomc
      lcint  = len_trim(file_cint);
      lih    = len_trim(file_ih);
      lico   = len_trim(file_ico);
      lclst  = len_trim(file_clst);
      latomc = len_trim(file_atomc);

      OPEN(UNIT=IREAD,FILE=file_atomc(1:latomc),STATUS='UNKNOWN')
      OPEN(UNIT=IOUT, FILE=file_cint(1:lcint), STATUS='UNKNOWN',
     :     FORM='unformatted')
      OPEN(UNIT=11, FILE=file_ih(1:lih), STATUS='UNKNOWN',
     :     FORM='unformatted')
      OPEN(UNIT=12, FILE=file_ico(1:lico), STATUS='UNKNOWN',
     :     FORM='unformatted')
      OPEN (UNIT=50,FILE=file_clst(1:lclst), STATUS='UNKNOWN',
     :     FORM='UNFORMATTED')
*
*     Let's postpone the restart for the time being
*
      CALL INITA
      CALL BREVALA(MASS)

      !close(IREAD)
      !close(IOUT)
      !close(11)
      !close(12)
      !close(50)

      if(myid == 0) print *, 'Finished with the file'

*      call etime(time)
*      write(iscw,'(//A/A//A,F8.3,A//)')
*     :       ' END OF CASE',' ===========',
*     :       ' Total time was ', time(1)/60, ' minutes'
      call MPI_FINALIZE(ierr)
      END program breit_matrix


      SUBROUTINE MRED2D
C
C     THIS SUBROUTINE CALCULATES THE MODAL MASS AND STIFFNESS MATRICES
C     IF USERMODE = TYPE2 FOR THE MRED2 MODULE.
C
C     INPUT DATA
C     GINO - USETMR  - USET TABLE FOR REDUCED SUBSTRUCTURE
C            LAMAMR  - EIGENVALUE TABLE FOR SUBSTRUCTURE BEING REDUCED
C            PHISS   - EIGENVECTORS FOR SUBSTRUCTURE BEING REDUCED
C            QSM     - MODEL REACTION MATRIX
C            PAA     - SUBSTRUCTURE LOAD MATRIX
C
C     OUTPUT DATA
C     GINO - KHH     - REDUCED STIFFNESS MATRIX
C            MHH     - REDUCED MASS MATRIX
C            PHH     - REDUCED LOAD MATRIX
C     SOF  - HORG    - H TRANSFORMATION MATRIX
C            KMTX    - STIFFNESS MATRIX FOR REDUCED SUBSTRUCTURE
C            MMTX    - MASS MATRIX FOR REDUCED SUBSTRUCTURE
C            PVEC    - LOAD MATRIX FOR REDUCED SUBSTRUCTURE
C            PAPP    - APPENDED LOAD MATRIX FOR REDUCED SUBSTRUCTURE
C            POVE    - INTERNAL POINT LOADS FOR ORIGINAL SUBSTRUCTURE
C            POAP    - INTERNAL POINTS APPENDED LOADS FOR ORIGINAL
C                       SUBSTRUCTURE
C
C     PARAMETERS
C     INPUT - DRY    - MODULE OPERATION FALG
C             GBUF   - GINO BUFFERS
C             INFILE - INPUT FILE NUMBERS
C             OTFILE - OUTPUT FILE NUMBERS
C             ISCR   - SCRATCH FILE NUMBERS
C             KORLEN - LENGTH OF OPEN CORE
C             KORBGN - BEGINNING ADDRESS OF OPEN CORE
C             OLDNAM - NAME OF SUBSTRUCTURE BEING REDUCED
C             NEWNAM - NAME OF REDUCED SUBSTRUCTURE
C             USRMOD - USERMODE FLAG
C
      INTEGER         DRY,POPT,GBUF1,SBUF1,SBUF2,SBUF3,OTFILE,OLDNAM,
     1                USRMOD,Z,UL,UA,UF,US,UN,UB,TYPIN,TYPOUT,TYPEA,
     2                TYPEB,PAA,PHH,RPRTN,CPRTN,BBZERO,ZERO,USETMR,SNB,
     3                PAPP
      DIMENSION       ITRLR(7),ITRLR1(7),ITRLR2(7),MODNAM(2),ITMLST(6),
     1                BLOCK(11),ISUB(4),ITMNAM(2),RZ(1)
      CHARACTER       UFM*23
      COMMON /XMSSG / UFM
      COMMON /BLANK / IDUM1,DRY,POPT,GBUF1,IDUM3(2),SBUF1,SBUF2,SBUF3,
     1                INFILE(12),OTFILE(6),ISCR(10),KORLEN,KORBGN,
     2                OLDNAM(2),NEWNAM(2),IDUM4(4),USRMOD,IDUM2(5),
     3                NMODES
      COMMON /ZZZZZZ/ Z(1)
      COMMON /TWO   / ITWO(32)
      COMMON /BITPOS/ IDUM5(5),UL,UA,UF,US,UN,IDUM6(10),UB
      COMMON /PACKX / TYPIN,TYPOUT,IROW,NROW,INCR
      COMMON /SYSTEM/ IDUM7,IPRNTR
      EQUIVALENCE     (USETMR,INFILE(5)),(KBB,INFILE(6)),
     1                (MBB,INFILE(7)),(PAA,INFILE(10)),
     2                (KHH,OTFILE(1)),(MHH,OTFILE(2)),(PHH,OTFILE(5)),
     3                (RPRTN,ISCR(8)),(CPRTN,ISCR(8)),(K,ISCR(3)),
     4                (BBZERO,ISCR(9)),(M,ISCR(10)),(ZERO,ISCR(3)),
     5                (RZ(1),Z(1)),(TYPEA,BLOCK(1)),(TYPEB,BLOCK(7))
      DATA    MODNAM/ 4HMRED,4H2D  /
      DATA    PAPP  / 4HPAPP/
      DATA    MRED2 / 27    /
      DATA    ITMLST/ 4HKMTX,4HMMTX,4HPVEC,4HPAPP,4HPOVE,4HPOAP/
C
C     CHECK USERMODE OPTION FLAG
C
      IF (DRY .EQ. -2) GO TO 400
C
C     COUNT NUMBER OF FREE, FIXED POINTS WITHIN BOUNDARY SET
C
      ITRLR(1) = USETMR
      CALL RDTRL(ITRLR)
      IFILE = USETMR
      IF (ITRLR(1) .LT. 0) GO TO 270
      LUSET = ITRLR(3)
      IF ((KORBGN + LUSET) .GE. KORLEN) GO TO 280
      CALL GOPEN (USETMR,Z(GBUF1),0)
      CALL READ  (*260,*270,USETMR,Z(KORBGN),LUSET,0,NWDSRD)
      CALL CLOSE (USETMR,1)
      NUF   = 0
      NUS   = 0
      SNB   = ITWO(US) + ITWO(UN) + ITWO(UB)
      LAFNB = ITWO(UL) + ITWO(UA) + ITWO(UF) + ITWO(UN) + ITWO(UB)
      DO 10 I = 1,LUSET
      IF (Z(KORBGN+I-1) .EQ. LAFNB) NUF = NUF + 1
      IF (Z(KORBGN+I-1) .EQ.   SNB) NUS = NUS + 1
   10 CONTINUE
C
C     IF FIXED SET, COMPUTE GS MATRIX
C
      IF (NUS .EQ. 0) GO TO 20
      CALL MRED2I (1,0,0)
C
C     IF FREE SET, PARTITION PHISS
C
   20 IF (NUF .EQ. 0) GO TO 50
      CALL MRED2J (NUF,N2)
C
C     FORM HK MATRIX
C
      CALL MRED2L (NUF,N2,NUS,UFBITS)
   50 CALL MRED2M (NUF,N2,NUS)
C
C     COMPUTE K MATRIX
C
      CALL MRED2N
C
C     COMPUTE HM MATRIX
C
      CALL MRED2O (NUS)
C
C     OUTPUT HORG
C
      CALL MRED2P (NUS,NUF,N2)
C
C     PROCESS STIFFNESS, MASS MATRICES
C     II = 1, PROCESS STIFFNESS MATRIX
C     II = 2, PROCESS MASS MATRIX
C
      IF (DRY .EQ. -2) GO TO 240
      CALL SETLVL (NEWNAM,1,OLDNAM,ITEST,MRED2)
      IF (ITEST .EQ. 8) GO TO 380
      DO 190 II = 1,2
      ITRLR1(1) = KBB
      KM   = K
      KMHH = KHH
      IF (II .EQ. 1) GO TO 60
      ITRLR1(1) = MBB
      KM   = M
      KMHH = MHH
   60 KMBB = ITRLR1(1)
      CALL RDTRL (ITRLR1)
      IF (ITRLR1(1) .LT. 0) GO TO 160
      CALL SOFCLS
C
C     FORM MERGE VECTOR
C
      JROW   = ITRLR1(3)
      KOLUMN = ITRLR1(2)
      ITRLR2(1) = KM
      CALL RDTRL (ITRLR2)
      NROW   = ITRLR2(3)
      KOLMNS = ITRLR2(2)
      DO 130 I = 1,NROW
      RZ(KORBGN+I-1) = 0.0
      IF (I .GT. JROW) RZ(KORBGN+I-1) = 1.0
  130 CONTINUE
      IFORM  = 7
      TYPIN  = 1
      TYPOUT = 1
      IROW   = 1
      INCR   = 1
      CALL MAKMCB (ITRLR1,RPRTN,NROW,IFORM,TYPIN)
      CALL GOPEN (RPRTN,Z(GBUF1),1)
      CALL PACK (Z(KORBGN),RPRTN,ITRLR1)
      CALL CLOSE (RPRTN,1)
      CALL WRTTRL (ITRLR1)
C
C     MERGE (K,M)BB MATRIX WITH ZERO MATRICES
C
      ISUB(1) = KOLUMN
      ISUB(2) = KOLMNS - KOLUMN
      ISUB(3) = JROW
      ISUB(4) = NROW - JROW
      ITYPE   = 1
      CALL GMMERG (BBZERO,KMBB,0,0,0,RPRTN,RPRTN,ISUB,ITYPE,Z(KORBGN),
     1             KORLEN)
C
C     FORM STIFFNESS, MASS MATRICES
C
C                                  **           **
C                                  *         .   *
C        **       **   **     **   * (K,M)BB . 0 *
C        *         *   *       *   *         .   *
C        * (K,M)HH * = * (K,M) * + *.............*
C        *         *   *       *   *         .   *
C        **       **   **     **   *    0    . 0 *
C                                  *         .   *
C                                  **           **
      DO 150 I = 1,11
  150 BLOCK(I) = 0.0
      BLOCK(2) = 1.0
      BLOCK(8) = 1.0
      TYPEA = ITRLR2(5)
      TYPEB = ITRLR1(5)
      IOP   = 1
      CALL SSG2C (KM,BBZERO,KMHH,IOP,BLOCK)
      CALL SOFOPN (Z(SBUF1),Z(SBUF2),Z(SBUF3))
      GO TO 170
C
C     NO BB MATRIX PARTITION
C
  160 KMHH = KM
C
C     STORE MATRIX ON SOF
C     II = 1, STORE KHH AS KMTX
C     II = 2, STORE MHH AS MMTX
C
  170 ITEM      = ITMLST(II)
      ITMNAM(1) = NEWNAM(1)
      ITMNAM(2) = NEWNAM(2)
      CALL MTRXO (KMHH,NEWNAM,ITEM,0,ITEST)
      IF (ITEST .NE. 3) GO TO 300
  190 CONTINUE
C
C     PROCESS LOAD DATA
C
      ITRLR1(1) = PAA
      CALL RDTRL (ITRLR1)
      IF (ITRLR1(1) .LT. 0) GO TO 240
C
C     EXPAND PAA FOR MODAL DOF
C
C                  **   **
C                  *     *
C        **   **   * PAA *
C        *     *   *     *
C        * PHH * = *.....*
C        *     *   *     *
C        **   **   *  0  *
C                  *     *
C                  **   **
C
      NROW = ITRLR1(3) + N2
      IF (N2 .EQ. 0) NROW = NROW + (NMODES - NUF)
      IFORM  = 7
      TYPIN  = 1
      TYPOUT = 1
      IROW   = 1
      INCR   = 1
      CALL MAKMCB (ITRLR2,CPRTN,NROW,IFORM,TYPIN)
      DO 230 I = 1,NROW
      RZ(KORBGN+I-1) = 0.0
      IF (I .GT. ITRLR1(3)) RZ(KORBGN+I-1) = 1.0
  230 CONTINUE
      CALL GOPEN (CPRTN,Z(GBUF1),1)
      CALL PACK (Z(KORBGN),CPRTN,ITRLR2)
      CALL CLOSE (CPRTN,1)
      CALL WRTTRL (ITRLR2)
C
C     MERGE PAA WITH ZERO MATRIX
C
      ISUB(3) = ITRLR1(3)
      ISUB(4) = N2
      IF (N2 .EQ. 0) ISUB(4) = NMODES - NUF
      ITYPE   = 1
      CALL GMMERG (PHH,PAA,0,0,0,0,CPRTN,ISUB,ITYPE,Z(KORBGN),KORLEN)
C
C     SAVE PHH AS PVEC OR PAPP ON SOF
C
      ITEM = ITMLST(3)
      IF (POPT .EQ. PAPP) ITEM = ITMLST(4)
      ITMNAM(1) = NEWNAM(1)
      ITMNAM(2) = NEWNAM(2)
      CALL MTRXO (PHH,NEWNAM,ITEM,0,ITEST)
      IF (ITEST .NE. 3) GO TO 300
C
C     STORE NULL MATRIX AS POVE OR POAP ON SOF
C
      IFORM  = 2
      KOLMNS = ITRLR1(2)
      NROW   = N2
      IF (N2 .EQ. 0) NROW = NMODES - NUF
      CALL MAKMCB (ITRLR2,ZERO,NROW,IFORM,TYPIN)
      CALL GOPEN (ZERO,Z(GBUF1),1)
      DO 234 I = 1,KOLMNS
      DO 232 J = 1,NROW
  232 RZ(KORBGN+J-1) = 0.0
  234 CALL PACK (Z(KORBGN),ZERO,ITRLR2)
      CALL CLOSE (ZERO,1)
      CALL WRTTRL (ITRLR2)
      ITEM = ITMLST(5)
      IF (POPT .EQ. PAPP) ITEM = ITMLST(6)
      ITMNAM(1) = OLDNAM(1)
      ITMNAM(2) = OLDNAM(2)
      CALL MTRXO (ZERO1,OLDNAM,ITEM,0,ITEST)
      IF (ITEST .NE. 3) GO TO 300
  240 CONTINUE
      GO TO 400
C
C     PROCESS SYSTEM FATAL ERRORS
C
  260 IMSG = -2
      GO TO 290
  270 IMSG = -3
      GO TO 290
  280 IMSG = -8
      IFILE = 0
  290 CALL SOFCLS
      CALL MESAGE (IMSG,IFILE,MODNAM)
      GO TO 400
C
C     PROCESS MODULE FATAL ERRORS
C
  300 GO TO (310,320,330,340,350,370), ITEST
  310 IMSG = -9
      GO TO 390
  320 IMSG = -11
      GO TO 390
  330 IMSG = -1
      GO TO 360
  340 IMSG = -2
      GO TO 360
  350 IMSG = -3
  360 CALL SMSG (IMSG,ITEM,ITMNAM)
      GO TO 400
  370 IMSG = -10
      GO TO 390
  380 WRITE  (IPRNTR,385) UFM
  385 FORMAT (A23,' 6518, ONE OF THE COMPONENT SUBSTRUCTURES HAS BEEN ',
     1       'USED IN A PREVIOUS COMBINE OR REDUCE.')
      DRY = -2
      GO TO 400
  390 DRY = -2
      CALL SMSG1 (IMSG,ITEM,ITMNAM,MODNAM)
  400 RETURN
      END