text:
!!  Copyright (C)  Stichting Deltares, 2012-2016.
!!
!!  This program is free software: you can redistribute it and/or modify
!!  it under the terms of the GNU General Public License version 3,
!!  as published by the Free Software Foundation.
!!
!!  This program is distributed in the hope that it will be useful,
!!  but WITHOUT ANY WARRANTY; without even the implied warranty of
!!  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!!  GNU General Public License for more details.
!!
!!  You should have received a copy of the GNU General Public License
!!  along with this program. If not, see <http://www.gnu.org/licenses/>.
!!
!!  contact: delft3d.support@deltares.nl
!!  Stichting Deltares
!!  P.O. Box 177
!!  2600 MH Delft, The Netherlands
!!
!!  All indications and logos of, and references to registered trademarks
!!  of Stichting Deltares remain the property of Stichting Deltares. All
!!  rights reserved.

      SUBROUTINE DLWQ5E ( LUNUT , IAR    , NOITM , ITMNR , NODIM  ,
     *                    IDMNR , IORDER , RAR   , IOPT  , RMAT   ,
     *                    NOCOL , NOBRK  , AMISS , IARP  , RMATU  )
!
!
!     Deltares        SECTOR WATERRESOURCES AND ENVIRONMENT
!
!     CREATED            : May   '98 by L. Postma
!
!     MODIFIED           :
!
!     FUNCTION           : Assign matrix according to computational
!                          rules
!
!     SUBROUTINES CALLED : none
!
!     LOGICAL UNITS      : LUNUT - report file
!
!     PARAMETERS    :
!
!     NAME    KIND     LENGTH     FUNCT.  DESCRIPTION
!     ---------------------------------------------------------
!     IAR     INTEGER    *         INPUT   array with arithmetic rules
!     NOITM   INTEGER    1         IN      number of items for computation
!     ITMNR   INTEGER    1         IN      number of items for output
!     NODIM   INTEGER    1         IN/OUT  number of conc. for comput.
!     IDMNR   INTEGER    1         IN/OUT  number of conc. for output
!     IORDER  INTEGER    1         INPUT   =1 items first: =2 concen first
!     RAR     REAL       *         INPUT   real constants in formulae
!     IOPT    LOGICAL    *         INPUT   3 & 4 is Fourier or harmonics
!     RMAT    REAL       *         INPUT   real matrix of read values
!     NOBRK   INTEGER    1         OUTPUT  number of records read
!     AMISS   REAL       1         INPUT   this is a missing value
!     IARP    INTEGER    *         INPUT   array with item pointers in RMAT
!     RMATU   REAL       *         OUTPUT  real matrix of evaluated values
!
!
      use timers       !   performance timers

      DIMENSION     IAR(*) , IARP(*) , RAR(*)  , RMAT(*) , RMATU(*)
      LOGICAL       MINIEM , MAXIEM
      integer(4) :: ithndl = 0
      if (timon) call timstrt( "dlwq5e", ithndl )
!
!     Some initialisation
!
      MINIEM = .FALSE.
      MAXIEM = .FALSE.
!     Loop end-value in integer array to determine IP
      IOFF1  = NOITM+ITMNR+IDMNR+NODIM
      IF ( IORDER .EQ. 1 ) THEN
         IOFF0  = NOITM+ITMNR+IDMNR
         LOCBAS = NODIM
      ENDIF
      IF ( IORDER .EQ. 2 ) THEN
         IOFF0  = NODIM+IDMNR+ITMNR
         LOCBAS = NOITM
      ENDIF
      ILOC  = 0
!          counter in output matrix
      ITEL  = 0
      ACCUM = 0.0
      ITELS = 0
!          implied loop counter for matrix, outer loop
      IFRST = 0
      IF ( IORDER .EQ. 1 .AND. NOITM .EQ. 0 ) IFRST = -1
      IF ( IORDER .EQ. 2 .AND. NODIM .EQ. 0 ) IFRST = -1
      IBRK  = 1
      IOFF  = 0
!
!     Assignment loop
!
!          if harmonics then deal with the phase
   10 IF ( ILOC .EQ. 0 .AND. (IOPT.EQ.3.OR.IOPT.EQ.4)
     *                 .AND.  IFRST .EQ. 0            ) THEN
         IOFF  = IOFF  + 1
         ACCUM = RMAT(IOFF)
         ITEL  = ITEL + 1
         RMATU(ITEL) = 0
      ENDIF
      ILOC = ILOC + 1
      IP   = IAR(ILOC+IOFF0)
      IP2  = IAR(ILOC+IOFF1)
!          normal processing
      IF ( IP .GT. -900000 ) THEN
!          close pending arrithmatic in the PREVIOUS ITEL
         IF ( ITEL .NE. 0 ) THEN
            IF ( RMATU(ITEL) .NE. AMISS .AND. ACCUM .NE. AMISS ) THEN
               RMATU(ITEL) = RMATU(ITEL) + ACCUM
            ELSE
               RMATU(ITEL) = AMISS
            ENDIF
            IF ( MAXIEM ) THEN
               IF ( RMATU(ITEL) .GT. AMAXV .AND.
     *              RMATU(ITEL) .NE. AMISS        ) THEN
                  WRITE ( LUNUT , 1000 ) IBRK, ILOCO, IFRST+1
                  WRITE ( LUNUT , 1010 ) RMATU(ITEL), AMAXV
                  RMATU(ITEL) = AMAXV
               ENDIF
            ENDIF
            IF ( MINIEM ) THEN
               IF ( RMATU(ITEL) .LT. AMINV .AND.
     *              RMATU(ITEL) .NE. AMISS        ) THEN
                  WRITE ( LUNUT , 1000 ) IBRK, ILOCO, IFRST+1
                  WRITE ( LUNUT , 1020 ) RMATU(ITEL), AMINV
                  RMATU(ITEL) = AMINV
               ENDIF
            ENDIF
            MAXIEM = .FALSE.
            MINIEM = .FALSE.
         ENDIF
         IF ( IP .GT. 0 ) THEN
            ACCUM = RMAT(IP2+IOFF)
         ELSE
            ACCUM = RAR(-IP)
         ENDIF
         ITEL  = ITEL + 1
         RMATU(ITEL) = 0
         ILOCO = IP
      ENDIF
!          ignore value
      IF ( IP .LE. -1300000000 ) THEN
         IP = 0
      ENDIF
!          a maximum value need to be applied
      IF ( IP .LE. -1190000000 ) THEN
         IP = IP +  1200000000
         IF ( RMATU(ITEL) .NE. AMISS .AND. ACCUM .NE. AMISS ) THEN
            RMATU(ITEL) = RMATU(ITEL) + ACCUM
         ELSE
            RMATU(ITEL) = AMISS
         ENDIF
         ACCUM = 0.0
         MAXIEM = .TRUE.
         IF ( IP .EQ. 0 ) THEN
            AMAXV = RMAT(IP2+IOFF)
         ENDIF
         IF ( IP .LT. 0 ) AMAXV = RAR(-IP)
         IF ( IP .GT. 0 ) AMAXV = RMATU(ITELS+IP)
      ENDIF
!          a minimum value need to be applied
      IF ( IP .LE. -1090000000 ) THEN
         IP = IP +  1100000000
         IF ( RMATU(ITEL) .NE. AMISS .AND. ACCUM .NE. AMISS ) THEN
            RMATU(ITEL) = RMATU(ITEL) + ACCUM
         ELSE
            RMATU(ITEL) = AMISS
         ENDIF
         ACCUM = 0.0
         MINIEM = .TRUE.
         IF ( IP .EQ. 0 ) THEN
            AMINV = RMAT(IP2+IOFF)
         ENDIF
         IF ( IP .LT. 0 ) AMINV = RAR(-IP)
         IF ( IP .GT. 0 ) AMINV = RMATU(ITELS+IP)
      ENDIF
!          a minus sign need to be applied
      IF ( IP .LE. -900000000 ) THEN
         IP = IP + 1000000000
         IF ( RMATU(ITEL) .NE. AMISS .AND. ACCUM .NE. AMISS ) THEN
            RMATU(ITEL) = RMATU(ITEL) + ACCUM
         ELSE
            RMATU(ITEL) = AMISS
         ENDIF
         IF ( IP .EQ. 0 ) THEN
            ACCUM = -RMAT(IP2+IOFF)
         ENDIF
         IF ( IP .LT. 0 ) ACCUM = -RAR(-IP)
         IF ( IP .GT. 0 ) ACCUM = -RMATU(ITELS+IP)
         IF ( ACCUM .EQ. -AMISS ) ACCUM = AMISS
      ENDIF
!          a plus sign need to be applied
      IF ( IP .LE. -90000000  ) THEN
         IP = IP + 100000000
         IF ( RMATU(ITEL) .NE. AMISS .AND. ACCUM .NE. AMISS ) THEN
            RMATU(ITEL) = RMATU(ITEL) + ACCUM
         ELSE
            RMATU(ITEL) = AMISS
         ENDIF
         IF ( IP .EQ. 0 ) THEN
            ACCUM =  RMAT(IP2+IOFF)
         ENDIF
         IF ( IP .LT. 0 ) ACCUM =  RAR(-IP)
         IF ( IP .GT. 0 ) ACCUM =  RMATU(ITELS+IP)
      ENDIF
!          a division need to be applied
      IF ( IP .LE. -9000000   ) THEN
         IP = IP + 10000000
         IF ( IP .EQ. 0 ) THEN
            IF ( RMAT(IP2+IOFF) .NE. AMISS .AND. ACCUM .NE. AMISS ) THEN
               ACCUM = ACCUM / RMAT(IP2+IOFF)
            ELSE
               ACCUM = AMISS
            ENDIF
         ENDIF
         IF ( IP .LT. 0 ) THEN
            IF ( RAR(-IP) .NE. AMISS .AND. ACCUM .NE. AMISS ) THEN
               ACCUM = ACCUM / RAR(-IP)
            ELSE
               ACCUM = AMISS
            ENDIF
         ENDIF
         IF ( IP .GT. 0 ) THEN
            IF ( RMAT(ITELS+IP) .NE. AMISS .AND. ACCUM .NE. AMISS ) THEN
               ACCUM = ACCUM / RMATU(ITELS+IP)
            ELSE
               ACCUM = AMISS
            ENDIF
         ENDIF
      ENDIF
!          a multiplication need to be applied
      IF ( IP .LE. -900000    ) THEN
         IP = IP + 1000000
         IF ( IP .EQ. 0 ) THEN
            IF ( RMAT(IP2+IOFF) .NE. AMISS .AND. ACCUM .NE. AMISS ) THEN
               ACCUM = ACCUM * RMAT(IP2+IOFF)
            ELSE
               ACCUM = AMISS
            ENDIF
         ENDIF
         IF ( IP .LT. 0 ) THEN
            IF ( RAR(-IP) .NE. AMISS .AND. ACCUM .NE. AMISS ) THEN
               ACCUM = ACCUM * RAR(-IP)
            ELSE
               ACCUM = AMISS
            ENDIF
         ENDIF
         IF ( IP .GT. 0 ) THEN
            IF ( RMAT(ITELS+IP) .NE. AMISS .AND. ACCUM .NE. AMISS ) THEN
               ACCUM = ACCUM * RMATU(ITELS+IP)
            ELSE
               ACCUM = AMISS
            ENDIF
         ENDIF
      ENDIF
      IF ( ILOC .EQ. LOCBAS ) THEN
         IF ( RMATU(ITEL) .NE. AMISS .AND. ACCUM .NE. AMISS ) THEN
            RMATU(ITEL) = RMATU(ITEL) + ACCUM
         ELSE
            RMATU(ITEL) = AMISS
         ENDIF
         IF ( MAXIEM ) THEN
            IF ( RMATU(ITEL) .GT. AMAXV .AND.
     *           RMATU(ITEL) .NE. AMISS       ) THEN
               WRITE ( LUNUT , 1000 ) IBRK, ILOCO, IFRST+1
               WRITE ( LUNUT , 1010 ) RMATU(ITEL), AMAXV
               RMATU(ITEL) = AMAXV
            ENDIF
         ENDIF
         IF ( MINIEM ) THEN
            IF ( RMATU(ITEL) .LT. AMINV .AND.
     *           RMATU(ITEL) .NE. AMISS       ) THEN
               WRITE ( LUNUT , 1000 ) IBRK, ILOCO, IFRST+1
               WRITE ( LUNUT , 1020 ) RMATU(ITEL), AMINV
               RMATU(ITEL) = AMINV
            ENDIF
         ENDIF
         MAXIEM = .FALSE.
         MINIEM = .FALSE.
         ACCUM = 0.0
         IFRST = IFRST + 1
         ITELS = ITEL
         ILOC  = 0
         IOFF  = IOFF + NOCOL
      ENDIF
!        are we to expect a new record ?
      IF ( ( IORDER .EQ. 1 .AND. IFRST.EQ.NOITM ) .OR.
     *     ( IORDER .EQ. 2 .AND. IFRST.EQ.NODIM ) )THEN
         IFRST  = 0
         IF ( IORDER .EQ. 1 .AND. NOITM .EQ. 0 ) IFRST = -1
         IF ( IORDER .EQ. 2 .AND. NODIM .EQ. 0 ) IFRST = -1
         IBRK   = IBRK + 1
      ENDIF
      IF ( IBRK .LE. NOBRK ) GOTO 10
!        compact the pointers
      IOFF1  = IOFF1+LOCBAS
      IF ( IORDER .EQ. 1 ) THEN
         IOFF0  = ITMNR
         IOFF2  = NOITM+ITMNR
         DO 20 I = 1,IDMNR
            IAR(IOFF0+I) = IAR(IOFF2+I)
   20    CONTINUE
         DO 30 I = 1,NOBRK
            IAR(IOFF0+IDMNR+I) = IAR(IOFF1+I)
   30    CONTINUE
      ENDIF
      IF ( IORDER .EQ. 2 ) THEN
         IOFF0  = IDMNR
         IOFF2  = NODIM+IDMNR
         DO 40 I = 1,ITMNR
            IAR(IOFF0+I) = IAR(IOFF2+I)
   40    CONTINUE
         DO 50 I = 1,NOBRK
            IAR(IOFF0+ITMNR+I) = IAR(IOFF1+I)
   50    CONTINUE
      ENDIF
      if (timon) call timstop( ithndl )
      RETURN
!
 1000 FORMAT ( ' INFO: Processing breakpoint',I6,' for substance',I3,
     *         ' at station',I5)
 1010 FORMAT ( ' the value of ',E15.6,' is overwritten by the maximum ',
     *         ' of ',E15.6,' !' )
 1020 FORMAT ( ' the value of ',E15.6,' is overwritten by the minimum ',
     *         ' of ',E15.6,' !' )
!
      END

max_stars_repo_name: liujiamingustc/phd

max_issues_repo_name: liujiamingustc/phd

max_forks_repo_name: liujiamingustc/phd


text:
C
C @(#)ppurge.f	7/31/97 from 3.16 (BNP) 5/11/89
C
      SUBROUTINE pPURGE(N,astore,LL,J,R,Q,RA,QA,WRK,ETA,OLDETA,MSGLVL,MPICOM)
      INTEGER N,LL,J,MSGLVL,MPICOM
      REAL*8 R(N),Q(N),RA(N),QA(N),WRK(N),ETA(J),OLDETA(J)
      REAL*8 Astore(*)
C
C.... This routine examines ETA to decide whether
C.... re-orthogonalization should be performed.
C
C.... N      (local) dimension of the eigenproblem
C.... LL     no. of initial Lanczos vectors in local orthog.
C.... J      current Lanczos step
C.... R      the residual vector to become the next Lanczos vector
C.... Q      the current Lanczos vector
C.... RA     the product of the mass matrix and r
C.... QA     the product of the mass matrix and q
C.... WRK    a temporary vector to hold the previous Lanczos vectors
C.... ETA    state of orthogonality between r and previous Lanczos vectors
C.... OLDETA state of orthogonality between q and previous Lanczos vectors
C.... MPICOM MPI Communicator
C
C.... BLAS routines:    DAXPY,DDOTMPI,IDAMAX
C.... subroutines:      none
C.... user-supplied:    OPM,STORE
C
      INCLUDE 'mpif.h'
      INTEGER RETRQ
      PARAMETER (RETRQ = 2)
C
      REAL*8 RNM,ANORM,TOL,EPS,EPS1,RCEPS1,EPSN,REPS,EPS34
      COMMON/RDATA/RNM,ANORM,TOL,EPS,EPS1,RCEPS1,EPSN,REPS,EPS34
      INTEGER K,I,LOOP,IDAMAX,MY_ID
      REAL*8 T,TQ,TR,REPS1,DDOTMPI
C
      IF (J.LE.LL+1) RETURN
      MY_ID = -1
      K = IDAMAX(J-(LL+1),ETA(LL+1),1)+LL
C
      IF (ABS(ETA(K)).GT.REPS) THEN
         IF (MSGLVL.GT.10) THEN
            CALL MPI_COMM_RANK(MPICOM, MY_ID, I)
            IF (MY_ID.EQ.0)
     &           PRINT *, 'PPURGE: Omega(', k, j+1, ') = ', abs(eta(k))
         ENDIF
         REPS1 = EPS1/REPS
         DO 55 LOOP = 1,2
            IF (RNM.GT.TOL) THEN
               IF (MY_ID.EQ.0 .AND. MSGLVL.GT.10) THEN
                  PRINT *, 'PPURGE: purging Q_', J, ' and R_', J,
     &                 ' LOOP #', LOOP
               ENDIF
C
C....       Bring in a Lanczos vector t and orthogonalize both r and q
C....       against it
C
               TQ = 0.0D0
               TR = 0.0D0
               DO 50 I = 1,J-1
                  CALL STORE(N,astore,RETRQ,I,WRK)
                  T = -DDOTMPI(N,QA,1,WRK,1,MPICOM)
                  TQ = TQ+ABS(T)
                  CALL DAXPY(N,T,WRK,1,Q,1)
                  T = -DDOTMPI(N,RA,1,WRK,1,MPICOM)
                  TR = TR+ABS(T)
                  CALL DAXPY(N,T,WRK,1,R,1)
50             CONTINUE
               CALL OPM(N,Q,QA,MPICOM)
C
C....          restore local orthogonality
C
               T = -DDOTMPI(N,R,1,QA,1,MPICOM)
               TR = TR+ABS(T)
               CALL DAXPY(N,T,Q,1,R,1)
C
               CALL OPM(N,R,RA,MPICOM)
               RNM = SQRT(DDOTMPI(N,RA,1,R,1,MPICOM))
               IF (TQ.LE.REPS1.AND.TR.LE.REPS1*RNM) GOTO 58
            ENDIF
55       CONTINUE
58       DO 60 I = LL+1,J
            ETA(I) = EPS1
            OLDETA(I) = EPS1
60       CONTINUE
      ENDIF
      RETURN
      END

ext: f


module ContactClass
	use std
	use MeshClass

	implicit none

	type :: Contact_

	end type

contains

! Element-By-Elementなどを定義したい。
! Gauss-point projectionを実装したい。

end module ContactClass


text:
#ifdef __GFORTRAN__

      Subroutine canteracppdlsodeV(ti,tout,neq,xgst)
      ! at constant volume
      ! 'ti' is the initial value of the independent variable.
      ! 'tout' is the first point where output is desired (.ne. ti).
      ! 'neq' is number of first order ode-s.
      ! 'xgst' is array of initial values, of length neq. The last value in this array is temperature. The others are mass fraction.
      implicit none
      include "chemkin/ckvariables.f"
      external CanteraUpdate

      integer itol,mf,itask,istate,iopt,lrw,liw
      double precision ti,tout,dt,atol,rtol,rjac
      !parameter (lrw=500,liw=500)
      !Have to make sure lrw, liw big enough, or it will have error like:
      !*** glibc detected *** ./a.out: double free or corruption (top):
      !*0x08901d70 ***
      !======= Backtrace: =========
      !/lib/libc.so.6(+0x6c501)[0x17c501]
      !/lib/libc.so.6(+0x6dd70)[0x17dd70]
      !/lib/libc.so.6(cfree+0x6d)[0x180e5d]
      !/lib/libc.so.6(fclose+0x14a)[0x16c81a]
      !./a.out[0x8048998]
      !/lib/libpthread.so.0(+0x5cc9)[0xc1fcc9]
      !/lib/libc.so.6(clone+0x5e)[0x1e069e]
      !======= Memory map: ========
      !parameter (lrw=500000,liw=500000)
      parameter (lrw=50000,liw=50000)
      double precision rwork(lrw),iwork(liw)
      integer neq
      double precision xgst(neq)
      common /lsodestore/ atol,rtol,mf,itask,istate,iopt,itol

      call dlsode (CanteraUpdate,neq,xgst,ti,tout,itol,rtol,atol,
     >itask,istate,iopt,rwork,lrw,iwork,liw,rjac,mf)

      Return
      End

      Subroutine canteracppdlsodaV(ti,tout,neq,xgst)
      ! at constant volume
      ! 'ti' is the initial value of the independent variable.
      ! 'tout' is the first point where output is desired (.ne. ti).
      ! 'neq' is number of first order ode-s.
      ! 'xgst' is array of initial values, of length neq. The last value in this array is temperature. The others are mass fraction.
      ! lsoda, mf should be jt
      implicit none
      include "chemkin/ckvariables.f"
      external CanteraUpdate

      integer itol,mf,itask,istate,iopt,lrw,liw,jt
      double precision ti,tout,dt,atol,rtol,jdum

      parameter (lrw=50000,liw=50000)
      double precision rwork(lrw),iwork(liw)
      integer neq
      double precision xgst(neq)
      common /lsodestore/ atol,rtol,mf,itask,istate,iopt,itol,jt

      call dlsoda (CanteraUpdate,neq,xgst,ti,tout,itol,rtol,atol,
     >itask,istate,iopt,rwork,lrw,iwork,liw,jdum,jt)

      Return
      End

#endif


text:
In addition to wiki gatherings where users get the chance to meet face to face there are many things that can be done to continue to foster a Wiki Demographics sense of community on DavisWiki.

 Welcoming users

Take the time to welcome new users to the wiki. If they have created a personal page a simple Welcome to the wiki! might be appropriate. If not, create one for them. You can point them toward resource pages that may be appropriate given their edit history.

 Notice Macro

Some new editors miss the yellow messages notice in the upper right hand corner. If there were a {{{Notice()}}} macro it would be possible to reach out to those editors and let them know that they need to read and respond to the comments on their userpage. The macro could be used to send a clear, unmissable message to another editor without having to blank out a page to get their attention. {{{Notice(username)}}} would show the following message the next time they visited the page: Other editors have been trying to give you information or ask you questions. Please check your {{{Users/username}}} page and respond to their comments. Other people viewing the page wouldnt see it, just the person it was addressed to.

 Encouraging Single Topic Editors to Branch Out

Single topic editors are those who edit only a single entry, or a small group of entries that all share one common topic. Often these are business owners and edit only the page with information about their business and pages that have links to it. Encouraging these editors to branch out and edit elsewhere on the wiki has two benefits:
  It reduces the a feeling of persecution for that editor. If they are only editing one page they may interpret other editors actions as hostile, rather than just part of the normal course of engaging in collaborative editing. If they edit a variety of pages they will learn more about the wiki and see that not every edit they make is later improved by another editor
  It makes the wiki more robust.

 Encouraging experimentation

If the processes by which pages and content are vetted are open and articulated new users who create inappropriate content are less likely to feel personally driven off when the page is deleted. Using the comment box when deleting pages or content is very important for this reason. When possible try to salvage the contribution.

 Social Norms

There are some very good social norms (Wiki Ethics) that have emerged. By living within them it is easier to socialize new users to follow them as well.

 Resources
  http://www.usemod.com/cgibin/mb.pl?WikiLifeCycle Wiki Life Cycle  see the section on Building Community.
  http://www.rheingold.com/texts/artonlinehost.html The Art of Hosting Good Conversations Online by http://www.rheingold.com/ Howard Rheingold

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


text:
C
C @(#)dsort2.f	3.2 (BNP) 12/9/88
C
      SUBROUTINE DSORT2(N,ARRAY1,ARRAY2)
      INTEGER N
      REAL*8 ARRAY1(0:N-1),ARRAY2(0:N-1)
C
C.... Sort array1 and array2 into increasing order for array1
C
      INTEGER IGAP,I,J
      REAL*8 TEMP
C
      IGAP = N/2
 10   IF (IGAP.GT.0) THEN
        DO 200 I = IGAP,N-1
          J = I-IGAP
 50       IF (ARRAY1(J).GT.ARRAY1(J+IGAP)) THEN
              TEMP = ARRAY1(J)
              ARRAY1(J) = ARRAY1(J+IGAP)
              ARRAY1(J+IGAP) = TEMP
              TEMP = ARRAY2(J)
              ARRAY2(J) = ARRAY2(J+IGAP)
              ARRAY2(J+IGAP) = TEMP
          ELSE
            GO TO 200
          ENDIF
          IF (J.GE.IGAP) THEN
             J = J-IGAP
             GO TO 50
          ENDIF
 200    CONTINUE
      ELSE
        RETURN
      ENDIF
      IGAP = IGAP/2
      GO TO 10
      END


text:
	SUBROUTINE GDTDSP  ( gdfile, gfunc,  gpoint, rgx,    rgy,  rlat,
     +			     rlon,   datmin, datmax, iscale, npts,
     +			     trange, panel,  iret )
C************************************************************************
C* GDTDSP								*
C*									*
C* This subroutine allows the user to exit from GDTSER.			*
C*									*
C* GDTDSP  ( GDFILE, GFUNC,  GPOINT, RGX,  RGY,    RLAT,  RLON,		*
C*           DATMIN, DATMAX, ISCALE, NPTS, TRANGE, PANEL, IRET )	*
C*									*
C* Input parameters:							*
C*	GDFILE		CHAR*		Grid file name			*
C*	GFUNC		CHAR*		Grid function			*
C*	GPOINT		CHAR*		Grid location			*
C*	RGX		REAL		X grid point			*
C*	RGY		REAL		Y grid point			*
C*	RLAT		REAL		Latitude			*
C*	RLON		REAL		Longitude			*
C*	DATMIN		REAL		Minimum data value		*
C*	DATMAX		REAL		Maximum data value		*
C*	ISCALE		INTEGER		Data scaling factor		*
C*	NPTS		INTEGER		Number of points		*
C*	TRANGE		CHAR*		Time range of grids		*
C*	PANEL		CHAR*		User input for panel location	*
C*									*
C* Output parameters:							*
C*	IRET		INTEGER		Return code			*
C*					  1 = user entered EXIT		*
C*					  0 = normal return		*
C**									*
C* Log:									*
C* G. Huffman/GSC	 2/89	Adapted from GDPDSP			*
C* S. Schotz/GSC	 6/90	Get respnd locally from IP_RESP		*
C* J. Whistler/SSAI	 5/91	Added commas around "/" in format 	*
C*				statements				*
C* R. Tian/SAIC         10/02   Added call to DG_IGRG                   *
C************************************************************************
	CHARACTER*(*)	gdfile, gfunc, gpoint, trange, panel
	LOGICAL		respnd
C*
C------------------------------------------------------------------------
	iret = 0
C
C*      Display grid as reference grid
C
	CALL DG_IGRG ( 1, rgx, rgy, rgx, rgy, ier )
C
C*	Write information to terminal.
C
	WRITE  ( 6, 1000 )
1000	FORMAT ( ' GDTSER PARAMETERS', /  )
	CALL ST_LSTR  ( gdfile, lenf, ier )
	CALL ST_LSTR  ( gfunc,  leng, ier )
	WRITE  ( 6, 1005, IOSTAT = iostat )  gdfile ( : lenf ),
     +					     gfunc ( : leng )
1005	FORMAT ( ' Grid file:                 ', A, /,
     +           ' Grid function:             ', A )
C
	isep = INDEX ( gpoint, ';' ) + INDEX ( gpoint, '/' )
	IF  ( isep .eq. 0 )  WRITE  ( 6, 1007 )  gpoint
1007	FORMAT ( ' Station:                   ', A )
C
	WRITE  ( 6, 1009 )  rgx,    rgy,    rlat,   rlon, npts, trange,
     +			    datmin, datmax, iscale, panel
1009	FORMAT ( ' X,Y grid point:          ',    0P2F8.2    , /,
     +           ' Lat/lon:                 ',    2F8.2      , /,
     +           ' Number of times:         ',    I4         , /,
     +           ' Date range:              ',    A          , /,
     +           ' Data range:              ',    1P2G12.4   , /,
     +           ' Data scale factor:       ',    '10 **', I3, /,
     +           ' Panel location:          ',    A           )
C
C*	Allow user to exit if respond is set.
C
	CALL IP_RESP ( respnd, ier )
	IF  ( respnd )  THEN
	    CALL TM_ACCP  ( ier )
	    IF  ( ier .eq. 2 )  iret = 1
	END IF
C*
	RETURN
	END

max_stars_repo_name: oxelson/gempak

max_issues_repo_name: oxelson/gempak

max_forks_repo_name: oxelson/gempak