SUBROUTINE correct_rotij(rotij, lattic,BR2,ORTHO, mult,nat,ndif)
  IMPLICIT NONE
  REAL*8, intent(inout):: rotij(3,3,ndif)
  REAL*8, intent(in)   :: BR2(3,3)   ! BR2(:,i) is primitive reciprocal vector b_i
  LOGICAL, intent(in)  :: ORTHO
  CHARACTER*4, intent(in) :: LATTIC
  INTEGER, intent(in)  :: mult(nat), nat, ndif
  ! locals
  INTEGER :: index, jatom, j
  REAL*8  :: RBAS(3,3), GBAS(3,3), tmp(3,3)
  REAL*8  :: det, PI

  PI=ACOS(-1.0D0)

  IF(.NOT. ORTHO.and.lattic(1:3).ne.'CXZ')  then !     for  mon.CXZ type rotation skipped (caution!!!)
     ! BR2 is primitive reciprocal vector
     GBAS(:,:) = BR2(:,:)/(2.0d0*PI)

     !! RBAS becomes primitive direct vectors
     tmp(:,:) = transpose(GBAS)
     call INVERSSYMDEF(tmp,RBAS)
     RBAS(:,:) = transpose(RBAS)

     index = 0
     DO jatom=1,nat
        DO j=1,mult(jatom)
           index = index + 1
           !  in dmft1 we used : rotij_cartesian = BR1 * rotij * BR1inv^{-1}
           !  but here we use  : rotij_cartesian = BR2 * rotij * ((BR2^T)^{-1})^T
           tmp = matmul(GBAS, rotij(:,:,index))
           rotij(:,:,index) = matmul(tmp, RBAS)
        enddo
     enddo
  endif

END SUBROUTINE correct_rotij


text:
	SUBROUTINE MR_SIGW  ( datsgw, nsgw, datasw, nasw, nlev, ipt,
     +			      stndat, idtype, sclhgt, iret )
C************************************************************************
C* MR_SIGW								*
C*									*
C* This subroutine adds significant wind data to the station data	*
C* array.  Pointers to the data ordered according to increasing 	*
C* height are returned.							*
C*									*
C* MR_SIGW  ( DATSGW, NSGW, DATASW, NASW, NLEV, IPT, STNDAT, IDTYPE,	*
C*            SCLHGT, IRET )						*
C*									*
C* Input parameters:							*
C*	DATSGW (3,NSGW)	REAL		Sig wind data below 100 mb	*
C*	NSGW		INTEGER		Number of levels below 100 mb	*
C*	DATASW (3,NASW)	REAL		Sig wind data above 100 mb	*
C*	NASW		INTEGER		Number of levels above 100 mb	*
C*									*
C* Input and output parameters:						*
C*	NLEV		INTEGER		Number of levels		*
C*	IPT    ( NLEV )	INTEGER		Pointers to ordered data	*
C*	STNDAT (6,NLEV)	REAL		Station data			*
C*	IDTYPE (NLEV)	INTEGER		Data type flags			*
C*					  1 = mandatory			*
C*					  2 = sig temperature		*
C*					  3 = sig wind			*
C*	SCLHGT ( NLEV )	REAL		Scale heights			*
C*									*
C* Output parameters:							*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C**									*
C* Log:									*
C* M. desJardins/GSFC	 9/86						*
C* M. desJardins/GSFC	 9/87	Rewritten for GEMPAK4			*
C* M. desJardins/GSFC	12/88	Fixed sig wind at mand lev		*
C* M. desJardins/GSFC	 1/89	Added IDTYPE				*
C* M. desJardins/GSFC	 4/89	Added check for missing spd or dir	*
C* T. Piper/SAIC	 2/02   Initialized znxt & zold; not always set	*
C* S. Jacobs/NCEP	10/10	Fixed updating sig winds at existing	*
C*				levels					*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C
	REAL		datsgw (3,*), datasw (3,*), stndat (6,*)
	REAL		sclhgt (*)
	INTEGER		ipt (*), idtype (*)
	LOGICAL		more, skip, above
C
	INCLUDE		'ERMISS.FNC'
C------------------------------------------------------------------------
	iret = 0
C
C*	Skip the surface data.
C
	IF ( (nsgw .ge. 1) .and. ( ( datsgw (1,1) .eq. 0. ) .or.
     +			( datsgw (1,1) .eq. stndat (1,1) ) ) )  THEN
	    istart = 2
	  ELSE
	    istart = 1
	END IF
C
C*	Merge only the heights between levels already in dataset.
C
	pressf = stndat ( 1, ipt (1) )
	hghtsf = stndat ( 6, ipt (1) )
	IF ( ( nlev .ge. 2 ) .and. ( .not. ERMISS ( pressf ) ) .and.
     +	     ( .not. ERMISS ( hghtsf ) ) )  THEN
	    more = .true.
	    zold = stndat ( 6, ipt (1) )
	    znxt = stndat ( 6, ipt (2) )
	    ilev = 2
	  ELSE IF  ( nlev .ge. 3 )  THEN
	    more = .true.
	    zold = stndat ( 6, ipt (2) )
	    znxt = stndat ( 6, ipt (3) )
	    ilev = 3
	  ELSE
	    znxt = RMISSD
	    zold = RMISSD
	END IF
	IF (( ERMISS ( zold ) ) .or. ( ERMISS ( znxt ) )) more = .false.
C
C*	Loop throught data below 100 mb. and then above.
C*	I points to next input data.
C
	IF  ( istart .le. nsgw ) THEN
	    above = .false.
	    i     = istart
	    iend  = nsgw
	  ELSE
	    above = .true.
	    i     = 1
	    iend  = nasw
	END IF
C*
	DO WHILE  ( more .and. ( i .le. iend ) )
	    IF ( .not. above ) THEN
		hght = datsgw (1,i)
		drct = datsgw (2,i)
		sped = datsgw (3,i)
	      ELSE
		hght = datasw (1,i)
		drct = datasw (2,i)
		sped = datasw (3,i)
	    END IF
	    skip = .false.
C
C*	    Skip this data if data is missing.
C
	    IF  ( ( ERMISS ( hght ) ) .or. ( ERMISS ( sped ) ) .or.
     +		  ( ERMISS ( drct ) ) )  THEN
		skip = .true.
C
C*		If this is an existing level, add winds if they were
C*		missing.
C
	      ELSE IF ( ABS ( zold - hght ) .lt. 1. ) THEN
		skip = .true.
		IF  ( ERMISS ( stndat ( 4, ipt (ilev - 1) ) ) .or.
     +		      ERMISS ( stndat ( 5, ipt (ilev - 1) ) ) )  THEN
		    stndat ( 4, ipt ( ilev - 1 ) ) = drct
		    stndat ( 5, ipt ( ilev - 1 ) ) = sped
		END IF
C
C*		Skip data is it is not above last data.
C
	      ELSE IF ( hght .le. zold ) THEN
		skip = .true.
C
C*		Check that bounding layers are correct.
C
	      ELSE IF ( hght .ge. znxt ) THEN
		DO WHILE  ( more .and. ( hght .gt. znxt ) )
		    zold = znxt
		    ilev = ilev + 1
		    IF ( ilev .gt. nlev ) THEN
			more = .false.
		      ELSE
			znxt = stndat ( 6, ipt (ilev) )
			IF  ( ERMISS ( znxt ) ) more = .false.
		    END IF
		END DO
	    END IF
C
C*	    Add new data to list.
C
	    IF  ( more .and. ( .not. skip ) )  THEN
C
C*		Add the wind data for this level, if it does not exist.
C
		IF  (  ABS ( znxt - hght ) .lt. 1. )  THEN
		    IF  ( ERMISS ( stndat ( 4, ipt (ilev) ) ) .or.
     +			  ERMISS ( stndat ( 5, ipt (ilev) ) ) )  THEN
			stndat ( 4, ipt ( ilev) ) = drct
			stndat ( 5, ipt ( ilev) ) = sped
		    END IF
C
C*		    Otherwise, add new level.
C
		  ELSE
		    nlev = nlev + 1
		    stndat ( 6, nlev ) = hght
		    stndat ( 4, nlev ) = drct
		    stndat ( 5, nlev ) = sped
		    DO  k = 1, 3
			stndat ( k, nlev ) = RMISSD
		    END DO
		    idtype ( nlev ) = 3
C
C*		    Add new station to ipt array.
C
		    DO  j = nlev, ilev + 1, -1
			ipt ( j )    = ipt ( j-1 )
C			sclhgt ( j ) = sclhgt ( j-1 )
		    END DO
		    ipt ( ilev ) = nlev
		    ilev = ilev + 1
		    zold = hght
		END IF
	    END IF
C
C*	    Set end of loop.  Change to data above 100 mb if below
C*	    is being processed and this is the last level.
C
	    IF ( ( .not. above ) .and. (i .eq. nsgw) ) THEN
		above = .true.
		i     = 1
		iend  = nasw
	      ELSE
		i     = i + 1
	    END IF
	END DO
C*
	RETURN
	END

ext: f

max_stars_repo_name: oxelson/gempak

max_issues_repo_name: oxelson/gempak

max_forks_repo_name: oxelson/gempak


text:
module object_m
  implicit none

  private

  type, public :: object_t
    private
    logical :: defined = .false.
  contains
    procedure :: user_defined
    procedure :: mark_as_defined
  end type

  interface

    pure module function user_defined(self) result(self_defined)
      implicit none
      class(object_t), intent(in) :: self
      logical self_defined
    end function

    pure module subroutine mark_as_defined(self)
      implicit none
      class(object_t), intent(inout) :: self
    end subroutine

  end interface

end module

max_stars_repo_name: sourceryinstitute/miniFAVOR

max_issues_repo_name: sourceryinstitute/miniFAVOR

max_forks_repo_name: sourceryinstitute/miniFAVOR


text:
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      SUBROUTINE CSA3XS (NI,XI,UI,WTS,KNOTS,SSMTH,NDERIV,NXO,NYO,NZO,
     +                  XO,YO,ZO,UO,NWRK,WORK,IER)
C
      DIMENSION XI(3,NI),UI(NI),WTS(*),KNOTS(3),XO(NXO),YO(NYO),
     +          ZO(NZO),UO(NXO,NYO,NZO),WORK(NWRK),NDERIV(3)
      DIMENSION XMN(3),XMX(3),XV(3)
C
C  Check on the number of knots.
C
      NTOT = KNOTS(1)*KNOTS(2)*KNOTS(3)
C
      DO 20 I=1,3
        IF (KNOTS(I) .LT. 4) THEN
          CALL CFAERR (202,' CSA3XS - must have at least four knots in e
     +very coordinate direction',68)
          IER = 202
          RETURN
        ENDIF
   20 CONTINUE
C
C  Check on the size of the workspace.
C
      IF (NWRK .LT. NTOT*(NTOT+3)) THEN
        CALL CFAERR (203,' CSA3XS - workspace too small',29)
        IER = 202
        RETURN
      ENDIF
C
C  Calculate the min and max for the knots as the minimum value of
C  the input data and output data and the maximum of the input and
C  output data.
C
      DO 30 J=1,3
        XMN(J) = XI(J,1)
        XMX(J) = XI(J,1)
        DO 10 I=2,NI
          XMN(J) = MIN(XMN(J),XI(J,I))
          XMX(J) = MAX(XMX(J),XI(J,I))
   10   CONTINUE
   30 CONTINUE
      XMN(1) = MIN(XMN(1),XO(1))
      XMX(1) = MAX(XMX(1),XO(NXO))
      XMN(2) = MIN(XMN(2),YO(1))
      XMX(2) = MAX(XMX(2),YO(NYO))
      XMN(3) = MIN(XMN(3),ZO(1))
      XMX(3) = MAX(XMX(3),ZO(NZO))
C
C  Find the coefficients.
C
      CALL SPLCW(3,XI,3,UI,WTS,NI,XMN,XMX,KNOTS,SSMTH,WORK,NTOT,
     +           WORK(NTOT+1),NWRK-NTOT,IERR)
      IF (IERR .NE. 0) RETURN
C
C  Calculate the approximated values (coefficients are stored at
C  the beginnig of WORK).
C
      DO 60 I=1,NXO
        XV(1) = XO(I)
        DO 40 J=1,NYO
          XV(2) = YO(J)
          DO 50 K=1,NZO
            XV(3) = ZO(K)
            UO(I,J,K) = SPLDE(3,XV,NDERIV,WORK,XMN,XMX,KNOTS,IER)
            IF (IERR .NE. 0) RETURN
   50     CONTINUE
   40   CONTINUE
   60 CONTINUE
C
      RETURN
      END

max_stars_repo_name: tenomoto/ncl

max_issues_repo_name: tenomoto/ncl

max_forks_repo_name: tenomoto/ncl


text:
This editor can edit this entry and tell us a bit about themselves by clicking the Edit icon.

20081113 15:35:07 nbsp Welcome to the Wiki Howdy Mr. (or Ms?) Truong, and Welcome to the Wiki! My names Evan, pleased to meet you!  Thanks for the review of Great Clips... I hope you find a better place to get your hair cut! Users/JabberWokky Evan JabberWokky Edwards

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


text:
C    @(#)del_brn_tp.f	20.3 2/13/96
C****************************************************************
C      File: del_brn_tp.f
C      Purpose: delete one transpose of a branch
C****************************************************************
C
       subroutine del_brn_tp(ptr)
       integer ptr

       include 'ipfinc/parametr.inc'

       include 'ipfinc/bus.inc'
       include 'ipfinc/branch.inc'

       integer p1, p2
C
C      Delete one transpose of a double-entry branch entity
C
       if ( ptr .gt. MAXBRN2  .or.  ptr .lt. 1 ) goto 9000
       k1 = kx(ptr)
       p1 = 0
       p2 = kbsdta(16,k1)
       do while ( p2 .ne. 0  .and.  p2 .ne. ptr )
          p1 = p2
          p2 = brnch_nxt(p2)
       enddo
       if ( p2 .ne. ptr ) goto 9000
       if (p1 .eq. 0) then
          kbsdta(16,k1) = brnch_nxt(ptr)
       else
          brnch_nxt(p1) = brnch_nxt(ptr)
       endif
       kx(ptr) = 7 777 777
       ky(ptr) = 7 777 777
       brnch_ptr(ptr) = 7 777 777
       brnch_nxt(ptr) = 7 777 777

       return

 9000  continue
       write(*,'(a)')' Programming error, bad branch link in' //
     &       ' DEL_BRN_TP'

       return
       end

max_stars_repo_name: mbheinen/bpa-ipf-tsp

max_issues_repo_name: cuihantao/bpa-ipf-tsp

max_forks_repo_name: mbheinen/bpa-ipf-tsp


text:
cdis    Forecast Systems Laboratory
cdis    NOAA/OAR/ERL/FSL
cdis    325 Broadway
cdis    Boulder, CO     80303
cdis
cdis    Forecast Research Division
cdis    Local Analysis and Prediction Branch
cdis    LAPS
cdis
cdis    This software and its documentation are in the public domain and
cdis    are furnished "as is."  The United States government, its
cdis    instrumentalities, officers, employees, and agents make no
cdis    warranty, express or implied, as to the usefulness of the software
cdis    and documentation for any purpose.  They assume no responsibility
cdis    (1) for the use of the software and documentation; or (2) to provide
cdis     technical support to users.
cdis
cdis    Permission to use, copy, modify, and distribute this software is
cdis    hereby granted, provided that the entire disclaimer notice appears
cdis    in all copies.  All modifications to this software must be clearly
cdis    documented, and are solely the responsibility of the agent making
cdis    the modifications.  If significant modifications or enhancements
cdis    are made to this software, the FSL Software Policy Manager
cdis    (softwaremgr@fsl.noaa.gov) should be notified.
cdis
cdis
cdis
cdis
cdis
cdis
cdis

        subroutine radar_to_latlon_old(lat_grid,lon_grid,height_grid
     1                  ,azimuth,slant_range,elev
     1                  ,rlat_radar,rlon_radar,rheight_radar)

        include 'trigd.inc'
        implicit real (a-z)

        if(rlat_radar .eq. 0.0)then
            write(6,*)' Warning, Radar Coords NOT Initialized'
        endif

        rpd = 3.141592653589/180.
        mpd = 111194.
        radius_earth = 6371.e3
        radius_earth_8_thirds = 6371.e3 * 2.6666666

        hor_dist = slant_range * cosd(elev)

        curvature = hor_dist **2 / radius_earth_8_thirds
        height_grid =
     1  slant_range * sind(elev) + curvature + rheight_radar

        height_factor =
     1   (radius_earth + 0.5 * (rheight_radar + height_grid))
     1  /radius_earth

        delta_x = sind(azimuth) * hor_dist / height_factor
        delta_y = cosd(azimuth) * hor_dist / height_factor

        delta_lat = delta_y / mpd

        lat_grid = rlat_radar + delta_lat

        cos_factor =  cosd( 0.5 * (rlat_radar + lat_grid ) )

        delta_lon = delta_x / mpd / cos_factor

        lon_grid = rlon_radar + delta_lon

        return

        end

        subroutine radar_to_latlon(lat_grid,lon_grid,height_grid
     1                  ,azimuth,slant_range,elev
     1                  ,rlat_radar,rlon_radar,rheight_radar)

cdoc    Calculate radar echo location given radar location and az/ran/elev
cdoc    of radar echo

        include 'trigd.inc'
        implicit real (a-z)

        real rlat_radar             ! I    (Degrees)
        real rlon_radar             ! I    (Degrees)
        real rheight_radar          ! I    (Meters)
        real azimuth                ! I    (Degrees)
        real slant_range            ! I    (Meters)
        real elev                   ! I    (Degrees)
        real lat_grid               ! O    (Degrees)
        real lon_grid               ! O    (Degrees)
        real height_grid            ! O    (Meters)

        integer i_status

        if(rlat_radar .eq. 0.0)then
            write(6,*)' Warning, Radar Coords NOT Initialized'
        endif

        rpd = 3.141592653589/180.
        mpd = 111194.
        radius_earth = 6371.e3
        radius_earth_8_thirds = 6371.e3 * 2.6666666

        hor_dist = slant_range * cosd(elev)

        curvature = hor_dist **2 / radius_earth_8_thirds
        height_grid =
     1  slant_range * sind(elev) + curvature + rheight_radar

        height_factor =
     1   (radius_earth + 0.5 * (rheight_radar + height_grid))
     1  /radius_earth

        r_range = hor_dist / height_factor * .001

!       write(12,*)r_range,azimuth

        call razm_lat_lon_gm(
     1          rlat_radar,                                           ! I
     1          rlon_radar,                                           ! I
     1          r_range,                                              ! I
     1          azimuth,                                              ! I
     1          lat_grid,                                             ! O
     1          lon_grid,                                             ! O
     1          i_status )                                            ! O

        if(i_status .ne. 1)then
            write(6,*)
     1         ' ERROR: Status check failed after razm_lat_lon_gm call'

            difflat = lat_grid - rlat_radar
            difflon = lon_grid - rlon_radar
            if(r_range .gt. 10000. .and. abs(difflat) .lt. .01
     1                             .and. abs(difflon) .lt. .01)then
                write(6,*)
     1           ' ERROR: QC check failed after razm_lat_lon_gm call'
                write(6,*)'difflat,difflon,r_range'
     1                    ,difflat,difflon,r_range
                write(6,*)'azimuth,rlat_radar,rlon_radar'
     1                    ,azimuth,rlat_radar,rlon_radar
            endif

            stop
        endif

        return

        end

max_stars_repo_name: maxinye/laps-mirror

max_stars_repo_licenses: Intel Unlicense OLDAP-2.2.1 NetCDF

max_issues_repo_name: longwosion/laps-mirror

max_issues_repo_licenses: Intel NetCDF OLDAP-2.2.1 Unlicense

max_forks_repo_name: longwosion/laps-mirror

max_forks_repo_licenses: Intel NetCDF OLDAP-2.2.1 Unlicense


text:
Jeremy Gimbel

Graduate of 2008 class

Political Science Poli Sci Major

Religious Studies Minor

Song Leader at Hillel House

Former neighbor of Users/JesseUnger

Former Chair of External Affairs Commission

Brother Alpha Epsilon Pi

Once played scrabble with Users/DanXie