text:
C-----------------------------------------------------------------------
      SUBROUTINE SPTGPSV(IROMB,MAXWV,KMAX,NPS,
     &                   KWSKIP,KGSKIP,NISKIP,NJSKIP,
     &                   TRUE,XMESH,ORIENT,WAVED,WAVEZ,UN,VN,US,VS)
C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM:  SPTGPSV    TRANSFORM SPECTRAL VECTOR TO POLAR STEREO.
C   PRGMMR: IREDELL       ORG: W/NMC23       DATE: 96-02-29
C
C ABSTRACT: THIS SUBPROGRAM PERFORMS A SPHERICAL TRANSFORM
C           FROM SPECTRAL COEFFICIENTS OF DIVERGENCES AND CURLS
C           TO VECTOR FIELDS ON A PAIR OF POLAR STEREOGRAPHIC GRIDS.
C           THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL.
C           THE WAVE AND GRID FIELDS MAY HAVE GENERAL INDEXING,
C           BUT EACH WAVE FIELD IS IN SEQUENTIAL 'IBM ORDER',
C           I.E. WITH ZONAL WAVENUMBER AS THE SLOWER INDEX.
C           THE TWO SQUARE POLAR STEREOGRAPHIC GRIDS ARE CENTERED
C           ON THE RESPECTIVE POLES, WITH THE ORIENTATION LONGITUDE
C           OF THE SOUTHERN HEMISPHERE GRID 180 DEGREES OPPOSITE
C           THAT OF THE NORTHERN HEMISPHERE GRID.
C           THE VECTORS ARE AUTOMATICALLY ROTATED TO BE RESOLVED
C           RELATIVE TO THE RESPECTIVE POLAR STEREOGRAPHIC GRIDS.
C
C           THE TRANSFORM IS MADE EFFICIENT             \ 4 | 5 /
C           BY COMBINING POINTS IN EIGHT SECTORS         \  |  /
C           OF EACH POLAR STEREOGRAPHIC GRID,           3 \ | / 6
C           NUMBERED AS IN THE DIAGRAM AT RIGHT.           \|/
C           THE POLE AND THE SECTOR BOUNDARIES          ----+----
C           ARE TREATED SPECIALLY IN THE CODE.             /|\
C           UNFORTUNATELY, THIS APPROACH INDUCES        2 / | \ 7
C           SOME HAIRY INDEXING AND CODE LOQUACITY,      /  |  \
C           FOR WHICH THE DEVELOPER APOLOGIZES.         / 1 | 8 \
C
C           THE TRANSFORMS ARE ALL MULTIPROCESSED OVER SECTOR POINTS.
C           TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION.
C           SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT.
C
C PROGRAM HISTORY LOG:
C   96-02-29  IREDELL
C 1998-12-15  IREDELL  OPENMP DIRECTIVES INSERTED
C
C USAGE:    CALL SPTGPSV(IROMB,MAXWV,KMAX,NPS,
C    &                   KWSKIP,KGSKIP,NISKIP,NJSKIP,
C    &                   TRUE,XMESH,ORIENT,WAVED,WAVEZ,UN,VN,US,VS)
C   INPUT ARGUMENTS:
C     IROMB    - INTEGER SPECTRAL DOMAIN SHAPE
C                (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL)
C     MAXWV    - INTEGER SPECTRAL TRUNCATION
C     KMAX     - INTEGER NUMBER OF FIELDS TO TRANSFORM.
C     NPS      - INTEGER ODD ORDER OF THE POLAR STEREOGRAPHIC GRIDS
C     KWSKIP   - INTEGER SKIP NUMBER BETWEEN WAVE FIELDS
C                (DEFAULTS TO (MAXWV+1)*((IROMB+1)*MAXWV+2) IF KWSKIP=0)
C     KGSKIP   - INTEGER SKIP NUMBER BETWEEN GRID FIELDS
C                (DEFAULTS TO NPS*NPS IF KGSKIP=0)
C     NISKIP   - INTEGER SKIP NUMBER BETWEEN GRID I-POINTS
C                (DEFAULTS TO 1 IF NISKIP=0)
C     NJSKIP   - INTEGER SKIP NUMBER BETWEEN GRID J-POINTS
C                (DEFAULTS TO NPS IF NJSKIP=0)
C     TRUE     - REAL LATITUDE AT WHICH PS GRID IS TRUE (USUALLY 60.)
C     XMESH    - REAL GRID LENGTH AT TRUE LATITUDE (M)
C     ORIENT   - REAL LONGITUDE AT BOTTOM OF NORTHERN PS GRID
C                (SOUTHERN PS GRID WILL HAVE OPPOSITE ORIENTATION.)
C     WAVED    - REAL (*) WAVE DIVERGENCE FIELDS
C     WAVEZ    - REAL (*) WAVE VORTICITY FIELDS
C   OUTPUT ARGUMENTS:
C     UN       - REAL (*) NORTHERN POLAR STEREOGRAPHIC U-WINDS
C     VN       - REAL (*) NORTHERN POLAR STEREOGRAPHIC V-WINDS
C     US       - REAL (*) SOUTHERN POLAR STEREOGRAPHIC U-WINDS
C     VS       - REAL (*) SOUTHERN POLAR STEREOGRAPHIC V-WINDS
C
C SUBPROGRAMS CALLED:
C   SPWGET       GET WAVE-SPACE CONSTANTS
C   SPLEGEND     COMPUTE LEGENDRE POLYNOMIALS
C   SPSYNTH      SYNTHESIZE FOURIER FROM SPECTRAL
C   SPDZ2UV      COMPUTE WINDS FROM DIVERGENCE AND VORTICITY
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 77
C
C$$$
      REAL WAVED(*),WAVEZ(*),UN(*),VN(*),US(*),VS(*)
      REAL EPS((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EPSTOP(MAXWV+1)
      REAL ENN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2)
      REAL ELONN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2)
      REAL EON((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EONTOP(MAXWV+1)
      INTEGER MP(2*KMAX)
      REAL SLON(MAXWV,8),CLON(MAXWV,8),SROT(0:3),CROT(0:3)
      REAL W((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2+1,2*KMAX)
      REAL WTOP(2*(MAXWV+1),2*KMAX)
      REAL PLN((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),PLNTOP(MAXWV+1)
      REAL F(2*MAXWV+3,2,2*KMAX)
      DATA SROT/0.,1.,0.,-1./,CROT/1.,0.,-1.,0./
      PARAMETER(RERTH=6.3712E6)
      PARAMETER(PI=3.14159265358979,DPR=180./PI)
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  CALCULATE PRELIMINARY CONSTANTS
      CALL SPWGET(IROMB,MAXWV,EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP)
      MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2
      MXTOP=MAXWV+1
      MDIM=2*MX+1
      IDIM=2*MAXWV+3
      KW=KWSKIP
      KG=KGSKIP
      NI=NISKIP
      NJ=NJSKIP
      IF(KW.EQ.0) KW=2*MX
      IF(KG.EQ.0) KG=NPS*NPS
      IF(NI.EQ.0) NI=1
      IF(NJ.EQ.0) NJ=NPS
      MP=1
      NPH=(NPS-1)/2
      GQ=((1.+SIN(TRUE/DPR))*RERTH/XMESH)**2
      SRH=SQRT(0.5)
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  CALCULATE SPECTRAL WINDS
C$OMP PARALLEL DO PRIVATE(KWS)
      DO K=1,KMAX
        KWS=(K-1)*KW
        CALL SPDZ2UV(IROMB,MAXWV,ENN1,ELONN1,EON,EONTOP,
     &               WAVED(KWS+1),WAVEZ(KWS+1),
     &               W(1,K),W(1,KMAX+K),WTOP(1,K),WTOP(1,KMAX+K))
      ENDDO
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  CALCULATE POLE POINT
      I1=NPH+1
      J1=NPH+1
      IJ1=(I1-1)*NI+(J1-1)*NJ+1
      SLAT1=1.
      CLAT1=0.
      CALL SPLEGEND(IROMB,MAXWV,SLAT1,CLAT1,EPS,EPSTOP,
     &              PLN,PLNTOP)
      CALL SPSYNTH(IROMB,MAXWV,2*MAXWV,IDIM,MDIM,2*MXTOP,2*KMAX,
     &             CLAT1,PLN,PLNTOP,MP,W,WTOP,F)
      COSO=COS(ORIENT/DPR)
      SINO=SIN(ORIENT/DPR)
CDIR$ IVDEP
      DO K=1,KMAX
        KU=K
        KV=K+KMAX
        IJK1=IJ1+(K-1)*KG
        UN(IJK1)=2*( COSO*F(3,1,KU)+SINO*F(3,1,KV))
        VN(IJK1)=2*(-SINO*F(3,1,KU)+COSO*F(3,1,KV))
        US(IJK1)=2*( COSO*F(3,2,KU)-SINO*F(3,2,KV))
        VS(IJK1)=2*( SINO*F(3,2,KU)+COSO*F(3,2,KV))
      ENDDO
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  CALCULATE POINTS ALONG THE ROW AND COLUMN OF THE POLE,
C  STARTING AT THE ORIENTATION LONGITUDE AND GOING CLOCKWISE.
C$OMP PARALLEL DO PRIVATE(I1,J2,I2,J3,I3,J4,I4,J5,I5,J6,I6,J7,I7,J8,I8)
C$OMP&       PRIVATE(IJ1,IJ2,IJ3,IJ4,IJ5,IJ6,IJ7,IJ8)
C$OMP&       PRIVATE(IJK1,IJK2,IJK3,IJK4,IJK5,IJK6,IJK7,IJK8)
C$OMP&       PRIVATE(DJ1,DI1,RQ,RR,RADLON,RADLON1,RADLON2,SLAT1,CLAT1)
C$OMP&       PRIVATE(PLN,PLNTOP,F,SLON,CLON,KU,KV,LR,LI)
      DO J1=1,NPH
        I1=NPH+1
        RADLON=ORIENT/DPR
        J3=NPS+1-I1
        I3=J1
        J5=NPS+1-J1
        I5=NPS+1-I1
        J7=I1
        I7=NPS+1-J1
        IJ1=(I1-1)*NI+(J1-1)*NJ+1
        IJ3=(I3-1)*NI+(J3-1)*NJ+1
        IJ5=(I5-1)*NI+(J5-1)*NJ+1
        IJ7=(I7-1)*NI+(J7-1)*NJ+1
        DI1=I1-NPH-1
        DJ1=J1-NPH-1
        RQ=DI1**2+DJ1**2
        SLAT1=(GQ-RQ)/(GQ+RQ)
        CLAT1=SQRT(1.-SLAT1**2)
        CALL SPLEGEND(IROMB,MAXWV,SLAT1,CLAT1,EPS,EPSTOP,
     &                PLN,PLNTOP)
        CALL SPSYNTH(IROMB,MAXWV,2*MAXWV,IDIM,MDIM,2*MXTOP,2*KMAX,
     &               CLAT1,PLN,PLNTOP,MP,W,WTOP,F)
        DO L=1,MAXWV
          SLON(L,1)=SIN(L*RADLON)
          CLON(L,1)=COS(L*RADLON)
          SLON(L,3)=SLON(L,1)*CROT(MOD(1*L,4))
     &             -CLON(L,1)*SROT(MOD(1*L,4))
          CLON(L,3)=CLON(L,1)*CROT(MOD(1*L,4))
     &             +SLON(L,1)*SROT(MOD(1*L,4))
          SLON(L,5)=SLON(L,1)*CROT(MOD(2*L,4))
     &             -CLON(L,1)*SROT(MOD(2*L,4))
          CLON(L,5)=CLON(L,1)*CROT(MOD(2*L,4))
     &             +SLON(L,1)*SROT(MOD(2*L,4))
          SLON(L,7)=SLON(L,1)*CROT(MOD(3*L,4))
     &             -CLON(L,1)*SROT(MOD(3*L,4))
          CLON(L,7)=CLON(L,1)*CROT(MOD(3*L,4))
     &             +SLON(L,1)*SROT(MOD(3*L,4))
        ENDDO
CDIR$ IVDEP
        DO K=1,KMAX
          KU=K
          KV=K+KMAX
          IJK1=IJ1+(K-1)*KG
          IJK3=IJ3+(K-1)*KG
          IJK5=IJ5+(K-1)*KG
          IJK7=IJ7+(K-1)*KG
          UN(IJK1)= F(1,1,KU)
          VN(IJK1)= F(1,1,KV)
          UN(IJK3)= F(1,1,KV)
          VN(IJK3)=-F(1,1,KU)
          UN(IJK5)=-F(1,1,KU)
          VN(IJK5)=-F(1,1,KV)
          UN(IJK7)=-F(1,1,KV)
          VN(IJK7)= F(1,1,KU)
          US(IJK1)=-F(1,2,KU)
          VS(IJK1)=-F(1,2,KV)
          US(IJK3)=-F(1,2,KV)
          VS(IJK3)= F(1,2,KU)
          US(IJK5)= F(1,2,KU)
          VS(IJK5)= F(1,2,KV)
          US(IJK7)= F(1,2,KV)
          VS(IJK7)=-F(1,2,KU)
        ENDDO
        IF(KMAX.EQ.1) THEN
          KU=1
          KV=2
          DO L=1,MAXWV
            LR=2*L+1
            LI=2*L+2
            UN(IJ1)=UN(IJ1)+2*(F(LR,1,KU)*CLON(L,1)
     &                        -F(LI,1,KU)*SLON(L,1))
            VN(IJ1)=VN(IJ1)+2*(F(LR,1,KV)*CLON(L,1)
     &                        -F(LI,1,KV)*SLON(L,1))
            UN(IJ3)=UN(IJ3)+2*(F(LR,1,KV)*CLON(L,3)
     &                        -F(LI,1,KV)*SLON(L,3))
            VN(IJ3)=VN(IJ3)-2*(F(LR,1,KU)*CLON(L,3)
     &                        -F(LI,1,KU)*SLON(L,3))
            UN(IJ5)=UN(IJ5)-2*(F(LR,1,KU)*CLON(L,5)
     &                        -F(LI,1,KU)*SLON(L,5))
            VN(IJ5)=VN(IJ5)-2*(F(LR,1,KV)*CLON(L,5)
     &                        -F(LI,1,KV)*SLON(L,5))
            UN(IJ7)=UN(IJ7)-2*(F(LR,1,KV)*CLON(L,7)
     &                        -F(LI,1,KV)*SLON(L,7))
            VN(IJ7)=VN(IJ7)+2*(F(LR,1,KU)*CLON(L,7)
     &                        -F(LI,1,KU)*SLON(L,7))
            US(IJ1)=US(IJ1)-2*(F(LR,2,KU)*CLON(L,5)
     &                        -F(LI,2,KU)*SLON(L,5))
            VS(IJ1)=VS(IJ1)-2*(F(LR,2,KV)*CLON(L,5)
     &                        -F(LI,2,KV)*SLON(L,5))
            US(IJ3)=US(IJ3)-2*(F(LR,2,KV)*CLON(L,3)
     &                        -F(LI,2,KV)*SLON(L,3))
            VS(IJ3)=VS(IJ3)+2*(F(LR,2,KU)*CLON(L,3)
     &                        -F(LI,2,KU)*SLON(L,3))
            US(IJ5)=US(IJ5)+2*(F(LR,2,KU)*CLON(L,1)
     &                        -F(LI,2,KU)*SLON(L,1))
            VS(IJ5)=VS(IJ5)+2*(F(LR,2,KV)*CLON(L,1)
     &                        -F(LI,2,KV)*SLON(L,1))
            US(IJ7)=US(IJ7)+2*(F(LR,2,KV)*CLON(L,7)
     &                        -F(LI,2,KV)*SLON(L,7))
            VS(IJ7)=VS(IJ7)-2*(F(LR,2,KU)*CLON(L,7)
     &                        -F(LI,2,KU)*SLON(L,7))
          ENDDO
        ELSE
          DO L=1,MAXWV
            LR=2*L+1
            LI=2*L+2
CDIR$ IVDEP
            DO K=1,KMAX
              KU=K
              KV=K+KMAX
              IJK1=IJ1+(K-1)*KG
              IJK3=IJ3+(K-1)*KG
              IJK5=IJ5+(K-1)*KG
              IJK7=IJ7+(K-1)*KG
              UN(IJK1)=UN(IJK1)+2*(F(LR,1,KU)*CLON(L,1)
     &                            -F(LI,1,KU)*SLON(L,1))
              VN(IJK1)=VN(IJK1)+2*(F(LR,1,KV)*CLON(L,1)
     &                            -F(LI,1,KV)*SLON(L,1))
              UN(IJK3)=UN(IJK3)+2*(F(LR,1,KV)*CLON(L,3)
     &                            -F(LI,1,KV)*SLON(L,3))
              VN(IJK3)=VN(IJK3)-2*(F(LR,1,KU)*CLON(L,3)
     &                            -F(LI,1,KU)*SLON(L,3))
              UN(IJK5)=UN(IJK5)-2*(F(LR,1,KU)*CLON(L,5)
     &                            -F(LI,1,KU)*SLON(L,5))
              VN(IJK5)=VN(IJK5)-2*(F(LR,1,KV)*CLON(L,5)
     &                            -F(LI,1,KV)*SLON(L,5))
              UN(IJK7)=UN(IJK7)-2*(F(LR,1,KV)*CLON(L,7)
     &                            -F(LI,1,KV)*SLON(L,7))
              VN(IJK7)=VN(IJK7)+2*(F(LR,1,KU)*CLON(L,7)
     &                            -F(LI,1,KU)*SLON(L,7))
              US(IJK1)=US(IJK1)-2*(F(LR,2,KU)*CLON(L,5)
     &                            -F(LI,2,KU)*SLON(L,5))
              VS(IJK1)=VS(IJK1)-2*(F(LR,2,KV)*CLON(L,5)
     &                            -F(LI,2,KV)*SLON(L,5))
              US(IJK3)=US(IJK3)-2*(F(LR,2,KV)*CLON(L,3)
     &                            -F(LI,2,KV)*SLON(L,3))
              VS(IJK3)=VS(IJK3)+2*(F(LR,2,KU)*CLON(L,3)
     &                            -F(LI,2,KU)*SLON(L,3))
              US(IJK5)=US(IJK5)+2*(F(LR,2,KU)*CLON(L,1)
     &                            -F(LI,2,KU)*SLON(L,1))
              VS(IJK5)=VS(IJK5)+2*(F(LR,2,KV)*CLON(L,1)
     &                            -F(LI,2,KV)*SLON(L,1))
              US(IJK7)=US(IJK7)+2*(F(LR,2,KV)*CLON(L,7)
     &                            -F(LI,2,KV)*SLON(L,7))
              VS(IJK7)=VS(IJK7)-2*(F(LR,2,KU)*CLON(L,7)
     &                            -F(LI,2,KU)*SLON(L,7))
            ENDDO
          ENDDO
        ENDIF
      ENDDO
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  CALCULATE POINTS ON THE MAIN DIAGONALS THROUGH THE POLE,
C  STARTING CLOCKWISE OF THE ORIENTATION LONGITUDE AND GOING CLOCKWISE.
C$OMP PARALLEL DO PRIVATE(I1,J2,I2,J3,I3,J4,I4,J5,I5,J6,I6,J7,I7,J8,I8)
C$OMP&       PRIVATE(IJ1,IJ2,IJ3,IJ4,IJ5,IJ6,IJ7,IJ8)
C$OMP&       PRIVATE(IJK1,IJK2,IJK3,IJK4,IJK5,IJK6,IJK7,IJK8)
C$OMP&       PRIVATE(DJ1,DI1,RQ,RR,RADLON,RADLON1,RADLON2,SLAT1,CLAT1)
C$OMP&       PRIVATE(PLN,PLNTOP,F,SLON,CLON,KU,KV,LR,LI)
      DO J1=1,NPH
        I1=J1
        RADLON=(ORIENT-45)/DPR
        J3=NPS+1-I1
        I3=J1
        J5=NPS+1-J1
        I5=NPS+1-I1
        J7=I1
        I7=NPS+1-J1
        IJ1=(I1-1)*NI+(J1-1)*NJ+1
        IJ3=(I3-1)*NI+(J3-1)*NJ+1
        IJ5=(I5-1)*NI+(J5-1)*NJ+1
        IJ7=(I7-1)*NI+(J7-1)*NJ+1
        DI1=I1-NPH-1
        DJ1=J1-NPH-1
        RQ=DI1**2+DJ1**2
        SLAT1=(GQ-RQ)/(GQ+RQ)
        CLAT1=SQRT(1.-SLAT1**2)
        CALL SPLEGEND(IROMB,MAXWV,SLAT1,CLAT1,EPS,EPSTOP,
     &                PLN,PLNTOP)
        CALL SPSYNTH(IROMB,MAXWV,2*MAXWV,IDIM,MDIM,2*MXTOP,2*KMAX,
     &               CLAT1,PLN,PLNTOP,MP,W,WTOP,F)
        DO L=1,MAXWV
          SLON(L,1)=SIN(L*RADLON)
          CLON(L,1)=COS(L*RADLON)
          SLON(L,3)=SLON(L,1)*CROT(MOD(1*L,4))
     &             -CLON(L,1)*SROT(MOD(1*L,4))
          CLON(L,3)=CLON(L,1)*CROT(MOD(1*L,4))
     &             +SLON(L,1)*SROT(MOD(1*L,4))
          SLON(L,5)=SLON(L,1)*CROT(MOD(2*L,4))
     &             -CLON(L,1)*SROT(MOD(2*L,4))
          CLON(L,5)=CLON(L,1)*CROT(MOD(2*L,4))
     &             +SLON(L,1)*SROT(MOD(2*L,4))
          SLON(L,7)=SLON(L,1)*CROT(MOD(3*L,4))
     &             -CLON(L,1)*SROT(MOD(3*L,4))
          CLON(L,7)=CLON(L,1)*CROT(MOD(3*L,4))
     &             +SLON(L,1)*SROT(MOD(3*L,4))
        ENDDO
CDIR$ IVDEP
        DO K=1,KMAX
          KU=K
          KV=K+KMAX
          IJK1=IJ1+(K-1)*KG
          IJK3=IJ3+(K-1)*KG
          IJK5=IJ5+(K-1)*KG
          IJK7=IJ7+(K-1)*KG
          UN(IJK1)=SRH*( F(1,1,KU)+F(1,1,KV))
          VN(IJK1)=SRH*(-F(1,1,KU)+F(1,1,KV))
          UN(IJK3)=SRH*(-F(1,1,KU)+F(1,1,KV))
          VN(IJK3)=SRH*(-F(1,1,KU)-F(1,1,KV))
          UN(IJK5)=SRH*(-F(1,1,KU)-F(1,1,KV))
          VN(IJK5)=SRH*( F(1,1,KU)-F(1,1,KV))
          UN(IJK7)=SRH*( F(1,1,KU)-F(1,1,KV))
          VN(IJK7)=SRH*( F(1,1,KU)+F(1,1,KV))
          US(IJK1)=SRH*(-F(1,2,KU)-F(1,2,KV))
          VS(IJK1)=SRH*( F(1,2,KU)-F(1,2,KV))
          US(IJK3)=SRH*( F(1,2,KU)-F(1,2,KV))
          VS(IJK3)=SRH*( F(1,2,KU)+F(1,2,KV))
          US(IJK5)=SRH*( F(1,2,KU)+F(1,2,KV))
          VS(IJK5)=SRH*(-F(1,2,KU)+F(1,2,KV))
          US(IJK7)=SRH*(-F(1,2,KU)+F(1,2,KV))
          VS(IJK7)=SRH*(-F(1,2,KU)-F(1,2,KV))
        ENDDO
        IF(KMAX.EQ.1) THEN
          KU=1
          KV=2
          DO L=1,MAXWV
            LR=2*L+1
            LI=2*L+2
            UN(IJ1)=UN(IJ1)+2*SRH*(( F(LR,1,KU)+F(LR,1,KV))
     &                             *CLON(L,1)
     &                            -( F(LI,1,KU)+F(LI,1,KV))
     &                             *SLON(L,1))
            VN(IJ1)=VN(IJ1)+2*SRH*((-F(LR,1,KU)+F(LR,1,KV))
     &                             *CLON(L,1)
     &                            -(-F(LI,1,KU)+F(LI,1,KV))
     &                             *SLON(L,1))
            UN(IJ3)=UN(IJ3)+2*SRH*((-F(LR,1,KU)+F(LR,1,KV))
     &                             *CLON(L,3)
     &                            -(-F(LI,1,KU)+F(LI,1,KV))
     &                             *SLON(L,3))
            VN(IJ3)=VN(IJ3)+2*SRH*((-F(LR,1,KU)-F(LR,1,KV))
     &                             *CLON(L,3)
     &                            -(-F(LI,1,KU)-F(LI,1,KV))
     &                             *SLON(L,3))
            UN(IJ5)=UN(IJ5)+2*SRH*((-F(LR,1,KU)-F(LR,1,KV))
     &                             *CLON(L,5)
     &                            -(-F(LI,1,KU)-F(LI,1,KV))
     &                             *SLON(L,5))
            VN(IJ5)=VN(IJ5)+2*SRH*(( F(LR,1,KU)-F(LR,1,KV))
     &                             *CLON(L,5)
     &                            -( F(LI,1,KU)-F(LI,1,KV))
     &                             *SLON(L,5))
            UN(IJ7)=UN(IJ7)+2*SRH*(( F(LR,1,KU)-F(LR,1,KV))
     &                             *CLON(L,7)
     &                            -( F(LI,1,KU)-F(LI,1,KV))
     &                             *SLON(L,7))
            VN(IJ7)=VN(IJ7)+2*SRH*(( F(LR,1,KU)+F(LR,1,KV))
     &                             *CLON(L,7)
     &                            -( F(LI,1,KU)+F(LI,1,KV))
     &                             *SLON(L,7))
            US(IJ1)=US(IJ1)+2*SRH*((-F(LR,2,KU)-F(LR,2,KV))
     &                             *CLON(L,3)
     &                            -(-F(LI,2,KU)-F(LI,2,KV))
     &                             *SLON(L,3))
            VS(IJ1)=VS(IJ1)+2*SRH*(( F(LR,2,KU)-F(LR,2,KV))
     &                             *CLON(L,3)
     &                            -( F(LI,2,KU)-F(LI,2,KV))
     &                             *SLON(L,3))
            US(IJ3)=US(IJ3)+2*SRH*(( F(LR,2,KU)-F(LR,2,KV))
     &                             *CLON(L,1)
     &                            -( F(LI,2,KU)-F(LI,2,KV))
     &                             *SLON(L,1))
            VS(IJ3)=VS(IJ3)+2*SRH*(( F(LR,2,KU)+F(LR,2,KV))
     &                             *CLON(L,1)
     &                            -( F(LI,2,KU)+F(LI,2,KV))
     &                             *SLON(L,1))
            US(IJ5)=US(IJ5)+2*SRH*(( F(LR,2,KU)+F(LR,2,KV))
     &                             *CLON(L,7)
     &                            -( F(LI,2,KU)+F(LI,2,KV))
     &                             *SLON(L,7))
            VS(IJ5)=VS(IJ5)+2*SRH*((-F(LR,2,KU)+F(LR,2,KV))
     &                             *CLON(L,7)
     &                            -(-F(LI,2,KU)+F(LI,2,KV))
     &                             *SLON(L,7))
            US(IJ7)=US(IJ7)+2*SRH*((-F(LR,2,KU)+F(LR,2,KV))
     &                             *CLON(L,5)
     &                            -(-F(LI,2,KU)+F(LI,2,KV))
     &                             *SLON(L,5))
            VS(IJ7)=VS(IJ7)+2*SRH*((-F(LR,2,KU)-F(LR,2,KV))
     &                             *CLON(L,5)
     &                            -(-F(LI,2,KU)-F(LI,2,KV))
     &                             *SLON(L,5))
          ENDDO
        ELSE
          DO L=1,MAXWV
            LR=2*L+1
            LI=2*L+2
CDIR$ IVDEP
            DO K=1,KMAX
              KU=K
              KV=K+KMAX
              IJK1=IJ1+(K-1)*KG
              IJK3=IJ3+(K-1)*KG
              IJK5=IJ5+(K-1)*KG
              IJK7=IJ7+(K-1)*KG
              UN(IJK1)=UN(IJK1)+2*SRH*(( F(LR,1,KU)+F(LR,1,KV))
     &                                 *CLON(L,1)
     &                                -( F(LI,1,KU)+F(LI,1,KV))
     &                                 *SLON(L,1))
              VN(IJK1)=VN(IJK1)+2*SRH*((-F(LR,1,KU)+F(LR,1,KV))
     &                                 *CLON(L,1)
     &                                -(-F(LI,1,KU)+F(LI,1,KV))
     &                                 *SLON(L,1))
              UN(IJK3)=UN(IJK3)+2*SRH*((-F(LR,1,KU)+F(LR,1,KV))
     &                                 *CLON(L,3)
     &                                -(-F(LI,1,KU)+F(LI,1,KV))
     &                                 *SLON(L,3))
              VN(IJK3)=VN(IJK3)+2*SRH*((-F(LR,1,KU)-F(LR,1,KV))
     &                                 *CLON(L,3)
     &                                -(-F(LI,1,KU)-F(LI,1,KV))
     &                                 *SLON(L,3))
              UN(IJK5)=UN(IJK5)+2*SRH*((-F(LR,1,KU)-F(LR,1,KV))
     &                                 *CLON(L,5)
     &                                -(-F(LI,1,KU)-F(LI,1,KV))
     &                                 *SLON(L,5))
              VN(IJK5)=VN(IJK5)+2*SRH*(( F(LR,1,KU)-F(LR,1,KV))
     &                                 *CLON(L,5)
     &                                -( F(LI,1,KU)-F(LI,1,KV))
     &                                 *SLON(L,5))
              UN(IJK7)=UN(IJK7)+2*SRH*(( F(LR,1,KU)-F(LR,1,KV))
     &                                 *CLON(L,7)
     &                                -( F(LI,1,KU)-F(LI,1,KV))
     &                                 *SLON(L,7))
              VN(IJK7)=VN(IJK7)+2*SRH*(( F(LR,1,KU)+F(LR,1,KV))
     &                                 *CLON(L,7)
     &                                -( F(LI,1,KU)+F(LI,1,KV))
     &                                 *SLON(L,7))
              US(IJK1)=US(IJK1)+2*SRH*((-F(LR,2,KU)-F(LR,2,KV))
     &                                 *CLON(L,3)
     &                                -(-F(LI,2,KU)-F(LI,2,KV))
     &                                 *SLON(L,3))
              VS(IJK1)=VS(IJK1)+2*SRH*(( F(LR,2,KU)-F(LR,2,KV))
     &                                 *CLON(L,3)
     &                                -( F(LI,2,KU)-F(LI,2,KV))
     &                                 *SLON(L,3))
              US(IJK3)=US(IJK3)+2*SRH*(( F(LR,2,KU)-F(LR,2,KV))
     &                                 *CLON(L,1)
     &                                -( F(LI,2,KU)-F(LI,2,KV))
     &                                 *SLON(L,1))
              VS(IJK3)=VS(IJK3)+2*SRH*(( F(LR,2,KU)+F(LR,2,KV))
     &                                 *CLON(L,1)
     &                                -( F(LI,2,KU)+F(LI,2,KV))
     &                                 *SLON(L,1))
              US(IJK5)=US(IJK5)+2*SRH*(( F(LR,2,KU)+F(LR,2,KV))
     &                                 *CLON(L,7)
     &                                -( F(LI,2,KU)+F(LI,2,KV))
     &                                 *SLON(L,7))
              VS(IJK5)=VS(IJK5)+2*SRH*((-F(LR,2,KU)+F(LR,2,KV))
     &                                 *CLON(L,7)
     &                                -(-F(LI,2,KU)+F(LI,2,KV))
     &                                 *SLON(L,7))
              US(IJK7)=US(IJK7)+2*SRH*((-F(LR,2,KU)+F(LR,2,KV))
     &                                 *CLON(L,5)
     &                                -(-F(LI,2,KU)+F(LI,2,KV))
     &                                 *SLON(L,5))
              VS(IJK7)=VS(IJK7)+2*SRH*((-F(LR,2,KU)-F(LR,2,KV))
     &                                 *CLON(L,5)
     &                                -(-F(LI,2,KU)-F(LI,2,KV))
     &                                 *SLON(L,5))
            ENDDO
          ENDDO
        ENDIF
      ENDDO
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  CALCULATE THE REMAINDER OF THE POLAR STEREOGRAPHIC DOMAIN,
C  STARTING AT THE SECTOR JUST CLOCKWISE OF THE ORIENTATION LONGITUDE
C  AND GOING CLOCKWISE UNTIL ALL EIGHT SECTORS ARE DONE.
C$OMP PARALLEL DO PRIVATE(I1,J2,I2,J3,I3,J4,I4,J5,I5,J6,I6,J7,I7,J8,I8)
C$OMP&       PRIVATE(IJ1,IJ2,IJ3,IJ4,IJ5,IJ6,IJ7,IJ8)
C$OMP&       PRIVATE(IJK1,IJK2,IJK3,IJK4,IJK5,IJK6,IJK7,IJK8)
C$OMP&       PRIVATE(DJ1,DI1,RQ,RR,RADLON,RADLON1,RADLON2,SLAT1,CLAT1)
C$OMP&       PRIVATE(PLN,PLNTOP,F,SLON,CLON,KU,KV,LR,LI)
      DO J1=1,NPH-1
        DO I1=J1+1,NPH
          J2=I1
          I2=J1
          J3=NPS+1-I1
          I3=J1
          J4=NPS+1-J1
          I4=I1
          J5=NPS+1-J1
          I5=NPS+1-I1
          J6=NPS+1-I1
          I6=NPS+1-J1
          J7=I1
          I7=NPS+1-J1
          J8=J1
          I8=NPS+1-I1
          IJ1=(I1-1)*NI+(J1-1)*NJ+1
          IJ2=(I2-1)*NI+(J2-1)*NJ+1
          IJ3=(I3-1)*NI+(J3-1)*NJ+1
          IJ4=(I4-1)*NI+(J4-1)*NJ+1
          IJ5=(I5-1)*NI+(J5-1)*NJ+1
          IJ6=(I6-1)*NI+(J6-1)*NJ+1
          IJ7=(I7-1)*NI+(J7-1)*NJ+1
          IJ8=(I8-1)*NI+(J8-1)*NJ+1
          DI1=I1-NPH-1
          DJ1=J1-NPH-1
          RQ=DI1**2+DJ1**2
          RR=SQRT(1/RQ)
          SLAT1=(GQ-RQ)/(GQ+RQ)
          CLAT1=SQRT(1.-SLAT1**2)
          RADLON1=ORIENT/DPR+ATAN(-DI1/DJ1)
          RADLON2=(ORIENT-45)/DPR*2-RADLON1
          CALL SPLEGEND(IROMB,MAXWV,SLAT1,CLAT1,EPS,EPSTOP,
     &                  PLN,PLNTOP)
          CALL SPSYNTH(IROMB,MAXWV,2*MAXWV,IDIM,MDIM,2*MXTOP,2*KMAX,
     &                 CLAT1,PLN,PLNTOP,MP,W,WTOP,F)
          DO L=1,MAXWV
            SLON(L,1)=SIN(L*RADLON1)
            CLON(L,1)=COS(L*RADLON1)
            SLON(L,2)=SIN(L*RADLON2)
            CLON(L,2)=COS(L*RADLON2)
            SLON(L,3)=SLON(L,1)*CROT(MOD(1*L,4))
     &               -CLON(L,1)*SROT(MOD(1*L,4))
            CLON(L,3)=CLON(L,1)*CROT(MOD(1*L,4))
     &               +SLON(L,1)*SROT(MOD(1*L,4))
            SLON(L,4)=SLON(L,2)*CROT(MOD(1*L,4))
     &               -CLON(L,2)*SROT(MOD(1*L,4))
            CLON(L,4)=CLON(L,2)*CROT(MOD(1*L,4))
     &               +SLON(L,2)*SROT(MOD(1*L,4))
            SLON(L,5)=SLON(L,1)*CROT(MOD(2*L,4))
     &               -CLON(L,1)*SROT(MOD(2*L,4))
            CLON(L,5)=CLON(L,1)*CROT(MOD(2*L,4))
     &               +SLON(L,1)*SROT(MOD(2*L,4))
            SLON(L,6)=SLON(L,2)*CROT(MOD(2*L,4))
     &               -CLON(L,2)*SROT(MOD(2*L,4))
            CLON(L,6)=CLON(L,2)*CROT(MOD(2*L,4))
     &               +SLON(L,2)*SROT(MOD(2*L,4))
            SLON(L,7)=SLON(L,1)*CROT(MOD(3*L,4))
     &               -CLON(L,1)*SROT(MOD(3*L,4))
            CLON(L,7)=CLON(L,1)*CROT(MOD(3*L,4))
     &               +SLON(L,1)*SROT(MOD(3*L,4))
            SLON(L,8)=SLON(L,2)*CROT(MOD(3*L,4))
     &               -CLON(L,2)*SROT(MOD(3*L,4))
            CLON(L,8)=CLON(L,2)*CROT(MOD(3*L,4))
     &               +SLON(L,2)*SROT(MOD(3*L,4))
          ENDDO
CDIR$ IVDEP
          DO K=1,KMAX
            KU=K
            KV=K+KMAX
            IJK1=IJ1+(K-1)*KG
            IJK2=IJ2+(K-1)*KG
            IJK3=IJ3+(K-1)*KG
            IJK4=IJ4+(K-1)*KG
            IJK5=IJ5+(K-1)*KG
            IJK6=IJ6+(K-1)*KG
            IJK7=IJ7+(K-1)*KG
            IJK8=IJ8+(K-1)*KG
            UN(IJK1)=RR*(-DJ1*F(1,1,KU)-DI1*F(1,1,KV))
            VN(IJK1)=RR*( DI1*F(1,1,KU)-DJ1*F(1,1,KV))
            UN(IJK2)=RR*(-DI1*F(1,1,KU)-DJ1*F(1,1,KV))
            VN(IJK2)=RR*( DJ1*F(1,1,KU)-DI1*F(1,1,KV))
            UN(IJK3)=RR*( DI1*F(1,1,KU)-DJ1*F(1,1,KV))
            VN(IJK3)=RR*( DJ1*F(1,1,KU)+DI1*F(1,1,KV))
            UN(IJK4)=RR*( DJ1*F(1,1,KU)-DI1*F(1,1,KV))
            VN(IJK4)=RR*( DI1*F(1,1,KU)+DJ1*F(1,1,KV))
            UN(IJK5)=RR*( DJ1*F(1,1,KU)+DI1*F(1,1,KV))
            VN(IJK5)=RR*(-DI1*F(1,1,KU)+DJ1*F(1,1,KV))
            UN(IJK6)=RR*( DI1*F(1,1,KU)+DJ1*F(1,1,KV))
            VN(IJK6)=RR*(-DJ1*F(1,1,KU)+DI1*F(1,1,KV))
            UN(IJK7)=RR*(-DI1*F(1,1,KU)+DJ1*F(1,1,KV))
            VN(IJK7)=RR*(-DJ1*F(1,1,KU)-DI1*F(1,1,KV))
            UN(IJK8)=RR*(-DJ1*F(1,1,KU)+DI1*F(1,1,KV))
            VN(IJK8)=RR*(-DI1*F(1,1,KU)-DJ1*F(1,1,KV))
            US(IJK1)=RR*( DJ1*F(1,2,KU)+DI1*F(1,2,KV))
            VS(IJK1)=RR*(-DI1*F(1,2,KU)+DJ1*F(1,2,KV))
            US(IJK2)=RR*( DI1*F(1,2,KU)+DJ1*F(1,2,KV))
            VS(IJK2)=RR*(-DJ1*F(1,2,KU)+DI1*F(1,2,KV))
            US(IJK3)=RR*(-DI1*F(1,2,KU)+DJ1*F(1,2,KV))
            VS(IJK3)=RR*(-DJ1*F(1,2,KU)-DI1*F(1,2,KV))
            US(IJK4)=RR*(-DJ1*F(1,2,KU)+DI1*F(1,2,KV))
            VS(IJK4)=RR*(-DI1*F(1,2,KU)-DJ1*F(1,2,KV))
            US(IJK5)=RR*(-DJ1*F(1,2,KU)-DI1*F(1,2,KV))
            VS(IJK5)=RR*( DI1*F(1,2,KU)-DJ1*F(1,2,KV))
            US(IJK6)=RR*(-DI1*F(1,2,KU)-DJ1*F(1,2,KV))
            VS(IJK6)=RR*( DJ1*F(1,2,KU)-DI1*F(1,2,KV))
            US(IJK7)=RR*( DI1*F(1,2,KU)-DJ1*F(1,2,KV))
            VS(IJK7)=RR*( DJ1*F(1,2,KU)+DI1*F(1,2,KV))
            US(IJK8)=RR*( DJ1*F(1,2,KU)-DI1*F(1,2,KV))
            VS(IJK8)=RR*( DI1*F(1,2,KU)+DJ1*F(1,2,KV))
          ENDDO
          IF(KMAX.EQ.1) THEN
            KU=1
            KV=2
            DO L=1,MAXWV
              LR=2*L+1
              LI=2*L+2
              UN(IJ1)=UN(IJ1)+2*RR*((-DJ1*F(LR,1,KU)-DI1*F(LR,1,KV))
     &                              *CLON(L,1)
     &                             -(-DJ1*F(LI,1,KU)-DI1*F(LI,1,KV))
     &                              *SLON(L,1))
              VN(IJ1)=VN(IJ1)+2*RR*(( DI1*F(LR,1,KU)-DJ1*F(LR,1,KV))
     &                              *CLON(L,1)
     &                             -( DI1*F(LI,1,KU)-DJ1*F(LI,1,KV))
     &                              *SLON(L,1))
              UN(IJ2)=UN(IJ2)+2*RR*((-DI1*F(LR,1,KU)-DJ1*F(LR,1,KV))
     &                              *CLON(L,2)
     &                             -(-DI1*F(LI,1,KU)-DJ1*F(LI,1,KV))
     &                              *SLON(L,2))
              VN(IJ2)=VN(IJ2)+2*RR*(( DJ1*F(LR,1,KU)-DI1*F(LR,1,KV))
     &                              *CLON(L,2)
     &                             -( DJ1*F(LI,1,KU)-DI1*F(LI,1,KV))
     &                              *SLON(L,2))
              UN(IJ3)=UN(IJ3)+2*RR*(( DI1*F(LR,1,KU)-DJ1*F(LR,1,KV))
     &                              *CLON(L,3)
     &                             -( DI1*F(LI,1,KU)-DJ1*F(LI,1,KV))
     &                              *SLON(L,3))
              VN(IJ3)=VN(IJ3)+2*RR*(( DJ1*F(LR,1,KU)+DI1*F(LR,1,KV))
     &                              *CLON(L,3)
     &                             -( DJ1*F(LI,1,KU)+DI1*F(LI,1,KV))
     &                              *SLON(L,3))
              UN(IJ4)=UN(IJ4)+2*RR*(( DJ1*F(LR,1,KU)-DI1*F(LR,1,KV))
     &                              *CLON(L,4)
     &                             -( DJ1*F(LI,1,KU)-DI1*F(LI,1,KV))
     &                              *SLON(L,4))
              VN(IJ4)=VN(IJ4)+2*RR*(( DI1*F(LR,1,KU)+DJ1*F(LR,1,KV))
     &                              *CLON(L,4)
     &                             -( DI1*F(LI,1,KU)+DJ1*F(LI,1,KV))
     &                              *SLON(L,4))
              UN(IJ5)=UN(IJ5)+2*RR*(( DJ1*F(LR,1,KU)+DI1*F(LR,1,KV))
     &                              *CLON(L,5)
     &                             -( DJ1*F(LI,1,KU)+DI1*F(LI,1,KV))
     &                              *SLON(L,5))
              VN(IJ5)=VN(IJ5)+2*RR*((-DI1*F(LR,1,KU)+DJ1*F(LR,1,KV))
     &                              *CLON(L,5)
     &                             -(-DI1*F(LI,1,KU)+DJ1*F(LI,1,KV))
     &                              *SLON(L,5))
              UN(IJ6)=UN(IJ6)+2*RR*(( DI1*F(LR,1,KU)+DJ1*F(LR,1,KV))
     &                              *CLON(L,6)
     &                             -( DI1*F(LI,1,KU)+DJ1*F(LI,1,KV))
     &                              *SLON(L,6))
              VN(IJ6)=VN(IJ6)+2*RR*((-DJ1*F(LR,1,KU)+DI1*F(LR,1,KV))
     &                              *CLON(L,6)
     &                             -(-DJ1*F(LI,1,KU)+DI1*F(LI,1,KV))
     &                              *SLON(L,6))
              UN(IJ7)=UN(IJ7)+2*RR*((-DI1*F(LR,1,KU)+DJ1*F(LR,1,KV))
     &                              *CLON(L,7)
     &                             -(-DI1*F(LI,1,KU)+DJ1*F(LI,1,KV))
     &                              *SLON(L,7))
              VN(IJ7)=VN(IJ7)+2*RR*((-DJ1*F(LR,1,KU)-DI1*F(LR,1,KV))
     &                              *CLON(L,7)
     &                             -(-DJ1*F(LI,1,KU)-DI1*F(LI,1,KV))
     &                              *SLON(L,7))
              UN(IJ8)=UN(IJ8)+2*RR*((-DJ1*F(LR,1,KU)+DI1*F(LR,1,KV))
     &                              *CLON(L,8)
     &                             -(-DJ1*F(LI,1,KU)+DI1*F(LI,1,KV))
     &                              *SLON(L,8))
              VN(IJ8)=VN(IJ8)+2*RR*((-DI1*F(LR,1,KU)-DJ1*F(LR,1,KV))
     &                              *CLON(L,8)
     &                             -(-DI1*F(LI,1,KU)-DJ1*F(LI,1,KV))
     &                              *SLON(L,8))
              US(IJ1)=US(IJ1)+2*RR*(( DJ1*F(LR,2,KU)+DI1*F(LR,2,KV))
     &                              *CLON(L,4)
     &                             -( DJ1*F(LI,2,KU)+DI1*F(LI,2,KV))
     &                              *SLON(L,4))
              VS(IJ1)=VS(IJ1)+2*RR*((-DI1*F(LR,2,KU)+DJ1*F(LR,2,KV))
     &                              *CLON(L,4)
     &                             -(-DI1*F(LI,2,KU)+DJ1*F(LI,2,KV))
     &                              *SLON(L,4))
              US(IJ2)=US(IJ2)+2*RR*(( DI1*F(LR,2,KU)+DJ1*F(LR,2,KV))
     &                              *CLON(L,3)
     &                             -( DI1*F(LI,2,KU)+DJ1*F(LI,2,KV))
     &                              *SLON(L,3))
              VS(IJ2)=VS(IJ2)+2*RR*((-DJ1*F(LR,2,KU)+DI1*F(LR,2,KV))
     &                              *CLON(L,3)
     &                             -(-DJ1*F(LI,2,KU)+DI1*F(LI,2,KV))
     &                              *SLON(L,3))
              US(IJ3)=US(IJ3)+2*RR*((-DI1*F(LR,2,KU)+DJ1*F(LR,2,KV))
     &                              *CLON(L,2)
     &                             -(-DI1*F(LI,2,KU)+DJ1*F(LI,2,KV))
     &                              *SLON(L,2))
              VS(IJ3)=VS(IJ3)+2*RR*((-DJ1*F(LR,2,KU)-DI1*F(LR,2,KV))
     &                              *CLON(L,2)
     &                             -(-DJ1*F(LI,2,KU)-DI1*F(LI,2,KV))
     &                              *SLON(L,2))
              US(IJ4)=US(IJ4)+2*RR*((-DJ1*F(LR,2,KU)+DI1*F(LR,2,KV))
     &                              *CLON(L,1)
     &                             -(-DJ1*F(LI,2,KU)+DI1*F(LI,2,KV))
     &                              *SLON(L,1))
              VS(IJ4)=VS(IJ4)+2*RR*((-DI1*F(LR,2,KU)-DJ1*F(LR,2,KV))
     &                              *CLON(L,1)
     &                             -(-DI1*F(LI,2,KU)-DJ1*F(LI,2,KV))
     &                              *SLON(L,1))
              US(IJ5)=US(IJ5)+2*RR*((-DJ1*F(LR,2,KU)-DI1*F(LR,2,KV))
     &                              *CLON(L,8)
     &                             -(-DJ1*F(LI,2,KU)-DI1*F(LI,2,KV))
     &                              *SLON(L,8))
              VS(IJ5)=VS(IJ5)+2*RR*(( DI1*F(LR,2,KU)-DJ1*F(LR,2,KV))
     &                              *CLON(L,8)
     &                             -( DI1*F(LI,2,KU)-DJ1*F(LI,2,KV))
     &                              *SLON(L,8))
              US(IJ6)=US(IJ6)+2*RR*((-DI1*F(LR,2,KU)-DJ1*F(LR,2,KV))
     &                              *CLON(L,7)
     &                             -(-DI1*F(LI,2,KU)-DJ1*F(LI,2,KV))
     &                              *SLON(L,7))
              VS(IJ6)=VS(IJ6)+2*RR*(( DJ1*F(LR,2,KU)-DI1*F(LR,2,KV))
     &                              *CLON(L,7)
     &                             -( DJ1*F(LI,2,KU)-DI1*F(LI,2,KV))
     &                              *SLON(L,7))
              US(IJ7)=US(IJ7)+2*RR*(( DI1*F(LR,2,KU)-DJ1*F(LR,2,KV))
     &                              *CLON(L,6)
     &                             -( DI1*F(LI,2,KU)-DJ1*F(LI,2,KV))
     &                              *SLON(L,6))
              VS(IJ7)=VS(IJ7)+2*RR*(( DJ1*F(LR,2,KU)+DI1*F(LR,2,KV))
     &                              *CLON(L,6)
     &                             -( DJ1*F(LI,2,KU)+DI1*F(LI,2,KV))
     &                              *SLON(L,6))
              US(IJ8)=US(IJ8)+2*RR*(( DJ1*F(LR,2,KU)-DI1*F(LR,2,KV))
     &                              *CLON(L,5)
     &                             -( DJ1*F(LI,2,KU)-DI1*F(LI,2,KV))
     &                              *SLON(L,5))
              VS(IJ8)=VS(IJ8)+2*RR*(( DI1*F(LR,2,KU)+DJ1*F(LR,2,KV))
     &                              *CLON(L,5)
     &                             -( DI1*F(LI,2,KU)+DJ1*F(LI,2,KV))
     &                              *SLON(L,5))
            ENDDO
          ELSE
            DO L=1,MAXWV
              LR=2*L+1
              LI=2*L+2
CDIR$ IVDEP
              DO K=1,KMAX
                KU=K
                KV=K+KMAX
                IJK1=IJ1+(K-1)*KG
                IJK2=IJ2+(K-1)*KG
                IJK3=IJ3+(K-1)*KG
                IJK4=IJ4+(K-1)*KG
                IJK5=IJ5+(K-1)*KG
                IJK6=IJ6+(K-1)*KG
                IJK7=IJ7+(K-1)*KG
                IJK8=IJ8+(K-1)*KG
                UN(IJK1)=UN(IJK1)+2*RR*((-DJ1*F(LR,1,KU)-DI1*F(LR,1,KV))
     &                                  *CLON(L,1)
     &                                 -(-DJ1*F(LI,1,KU)-DI1*F(LI,1,KV))
     &                                  *SLON(L,1))
                VN(IJK1)=VN(IJK1)+2*RR*(( DI1*F(LR,1,KU)-DJ1*F(LR,1,KV))
     &                                  *CLON(L,1)
     &                                 -( DI1*F(LI,1,KU)-DJ1*F(LI,1,KV))
     &                                  *SLON(L,1))
                UN(IJK2)=UN(IJK2)+2*RR*((-DI1*F(LR,1,KU)-DJ1*F(LR,1,KV))
     &                                  *CLON(L,2)
     &                                 -(-DI1*F(LI,1,KU)-DJ1*F(LI,1,KV))
     &                                  *SLON(L,2))
                VN(IJK2)=VN(IJK2)+2*RR*(( DJ1*F(LR,1,KU)-DI1*F(LR,1,KV))
     &                                  *CLON(L,2)
     &                                 -( DJ1*F(LI,1,KU)-DI1*F(LI,1,KV))
     &                                  *SLON(L,2))
                UN(IJK3)=UN(IJK3)+2*RR*(( DI1*F(LR,1,KU)-DJ1*F(LR,1,KV))
     &                                  *CLON(L,3)
     &                                 -( DI1*F(LI,1,KU)-DJ1*F(LI,1,KV))
     &                                  *SLON(L,3))
                VN(IJK3)=VN(IJK3)+2*RR*(( DJ1*F(LR,1,KU)+DI1*F(LR,1,KV))
     &                                  *CLON(L,3)
     &                                 -( DJ1*F(LI,1,KU)+DI1*F(LI,1,KV))
     &                                  *SLON(L,3))
                UN(IJK4)=UN(IJK4)+2*RR*(( DJ1*F(LR,1,KU)-DI1*F(LR,1,KV))
     &                                  *CLON(L,4)
     &                                 -( DJ1*F(LI,1,KU)-DI1*F(LI,1,KV))
     &                                  *SLON(L,4))
                VN(IJK4)=VN(IJK4)+2*RR*(( DI1*F(LR,1,KU)+DJ1*F(LR,1,KV))
     &                                  *CLON(L,4)
     &                                 -( DI1*F(LI,1,KU)+DJ1*F(LI,1,KV))
     &                                  *SLON(L,4))
                UN(IJK5)=UN(IJK5)+2*RR*(( DJ1*F(LR,1,KU)+DI1*F(LR,1,KV))
     &                                  *CLON(L,5)
     &                                 -( DJ1*F(LI,1,KU)+DI1*F(LI,1,KV))
     &                                  *SLON(L,5))
                VN(IJK5)=VN(IJK5)+2*RR*((-DI1*F(LR,1,KU)+DJ1*F(LR,1,KV))
     &                                  *CLON(L,5)
     &                                 -(-DI1*F(LI,1,KU)+DJ1*F(LI,1,KV))
     &                                  *SLON(L,5))
                UN(IJK6)=UN(IJK6)+2*RR*(( DI1*F(LR,1,KU)+DJ1*F(LR,1,KV))
     &                                  *CLON(L,6)
     &                                 -( DI1*F(LI,1,KU)+DJ1*F(LI,1,KV))
     &                                  *SLON(L,6))
                VN(IJK6)=VN(IJK6)+2*RR*((-DJ1*F(LR,1,KU)+DI1*F(LR,1,KV))
     &                                  *CLON(L,6)
     &                                 -(-DJ1*F(LI,1,KU)+DI1*F(LI,1,KV))
     &                                  *SLON(L,6))
                UN(IJK7)=UN(IJK7)+2*RR*((-DI1*F(LR,1,KU)+DJ1*F(LR,1,KV))
     &                                  *CLON(L,7)
     &                                 -(-DI1*F(LI,1,KU)+DJ1*F(LI,1,KV))
     &                                  *SLON(L,7))
                VN(IJK7)=VN(IJK7)+2*RR*((-DJ1*F(LR,1,KU)-DI1*F(LR,1,KV))
     &                                  *CLON(L,7)
     &                                 -(-DJ1*F(LI,1,KU)-DI1*F(LI,1,KV))
     &                                  *SLON(L,7))
                UN(IJK8)=UN(IJK8)+2*RR*((-DJ1*F(LR,1,KU)+DI1*F(LR,1,KV))
     &                                  *CLON(L,8)
     &                                 -(-DJ1*F(LI,1,KU)+DI1*F(LI,1,KV))
     &                                  *SLON(L,8))
                VN(IJK8)=VN(IJK8)+2*RR*((-DI1*F(LR,1,KU)-DJ1*F(LR,1,KV))
     &                                  *CLON(L,8)
     &                                 -(-DI1*F(LI,1,KU)-DJ1*F(LI,1,KV))
     &                                  *SLON(L,8))
                US(IJK1)=US(IJK1)+2*RR*(( DJ1*F(LR,2,KU)+DI1*F(LR,2,KV))
     &                                  *CLON(L,4)
     &                                 -( DJ1*F(LI,2,KU)+DI1*F(LI,2,KV))
     &                                  *SLON(L,4))
                VS(IJK1)=VS(IJK1)+2*RR*((-DI1*F(LR,2,KU)+DJ1*F(LR,2,KV))
     &                                  *CLON(L,4)
     &                                 -(-DI1*F(LI,2,KU)+DJ1*F(LI,2,KV))
     &                                  *SLON(L,4))
                US(IJK2)=US(IJK2)+2*RR*(( DI1*F(LR,2,KU)+DJ1*F(LR,2,KV))
     &                                  *CLON(L,3)
     &                                 -( DI1*F(LI,2,KU)+DJ1*F(LI,2,KV))
     &                                  *SLON(L,3))
                VS(IJK2)=VS(IJK2)+2*RR*((-DJ1*F(LR,2,KU)+DI1*F(LR,2,KV))
     &                                  *CLON(L,3)
     &                                 -(-DJ1*F(LI,2,KU)+DI1*F(LI,2,KV))
     &                                  *SLON(L,3))
                US(IJK3)=US(IJK3)+2*RR*((-DI1*F(LR,2,KU)+DJ1*F(LR,2,KV))
     &                                  *CLON(L,2)
     &                                 -(-DI1*F(LI,2,KU)+DJ1*F(LI,2,KV))
     &                                  *SLON(L,2))
                VS(IJK3)=VS(IJK3)+2*RR*((-DJ1*F(LR,2,KU)-DI1*F(LR,2,KV))
     &                                  *CLON(L,2)
     &                                 -(-DJ1*F(LI,2,KU)-DI1*F(LI,2,KV))
     &                                  *SLON(L,2))
                US(IJK4)=US(IJK4)+2*RR*((-DJ1*F(LR,2,KU)+DI1*F(LR,2,KV))
     &                                  *CLON(L,1)
     &                                 -(-DJ1*F(LI,2,KU)+DI1*F(LI,2,KV))
     &                                  *SLON(L,1))
                VS(IJK4)=VS(IJK4)+2*RR*((-DI1*F(LR,2,KU)-DJ1*F(LR,2,KV))
     &                                  *CLON(L,1)
     &                                 -(-DI1*F(LI,2,KU)-DJ1*F(LI,2,KV))
     &                                  *SLON(L,1))
                US(IJK5)=US(IJK5)+2*RR*((-DJ1*F(LR,2,KU)-DI1*F(LR,2,KV))
     &                                  *CLON(L,8)
     &                                 -(-DJ1*F(LI,2,KU)-DI1*F(LI,2,KV))
     &                                  *SLON(L,8))
                VS(IJK5)=VS(IJK5)+2*RR*(( DI1*F(LR,2,KU)-DJ1*F(LR,2,KV))
     &                                  *CLON(L,8)
     &                                 -( DI1*F(LI,2,KU)-DJ1*F(LI,2,KV))
     &                                  *SLON(L,8))
                US(IJK6)=US(IJK6)+2*RR*((-DI1*F(LR,2,KU)-DJ1*F(LR,2,KV))
     &                                  *CLON(L,7)
     &                                 -(-DI1*F(LI,2,KU)-DJ1*F(LI,2,KV))
     &                                  *SLON(L,7))
                VS(IJK6)=VS(IJK6)+2*RR*(( DJ1*F(LR,2,KU)-DI1*F(LR,2,KV))
     &                                  *CLON(L,7)
     &                                 -( DJ1*F(LI,2,KU)-DI1*F(LI,2,KV))
     &                                  *SLON(L,7))
                US(IJK7)=US(IJK7)+2*RR*(( DI1*F(LR,2,KU)-DJ1*F(LR,2,KV))
     &                                  *CLON(L,6)
     &                                 -( DI1*F(LI,2,KU)-DJ1*F(LI,2,KV))
     &                                  *SLON(L,6))
                VS(IJK7)=VS(IJK7)+2*RR*(( DJ1*F(LR,2,KU)+DI1*F(LR,2,KV))
     &                                  *CLON(L,6)
     &                                 -( DJ1*F(LI,2,KU)+DI1*F(LI,2,KV))
     &                                  *SLON(L,6))
                US(IJK8)=US(IJK8)+2*RR*(( DJ1*F(LR,2,KU)-DI1*F(LR,2,KV))
     &                                  *CLON(L,5)
     &                                 -( DJ1*F(LI,2,KU)-DI1*F(LI,2,KV))
     &                                  *SLON(L,5))
                VS(IJK8)=VS(IJK8)+2*RR*(( DI1*F(LR,2,KU)+DJ1*F(LR,2,KV))
     &                                  *CLON(L,5)
     &                                 -( DI1*F(LI,2,KU)+DJ1*F(LI,2,KV))
     &                                  *SLON(L,5))
              ENDDO
            ENDDO
          ENDIF
        ENDDO
      ENDDO
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      END

max_stars_repo_name: GMAO-SI-Team/jedi-stack

max_issues_repo_name: GMAO-SI-Team/jedi-stack


text:
       subroutine Hpsi_comp(wg,wgh,ilocal,vr,workr_n,kpt,
     &  isij,swg,sumdum,iislda)

******************************************
cc     Written by Lin-Wang Wang, March 30, 2001.
*************************************************************************
**  copyright (c) 2003, The Regents of the University of California,
**  through Lawrence Berkeley National Laboratory (subject to receipt of any
**  required approvals from the U.S. Dept. of Energy).  All rights reserved.
*************************************************************************

******************************************

********* wgh = H * wg
********* swg= wg+Qij*wg     ! execute only when isij=1 and ipsp_all=2,  used for orth.
*********                    ! otherwise, swg is a dummy

***** cphase is not installed yet

       use fft_data
       use load_data
       use data

       implicit double precision (a-h,o-z)
       include 'param.escan_real'
       include "mpif.h"

       real*8 vr(mr_n)
       complex*16 workr_n(mr_n)
       complex*16 wg(mg_nx),wgh(mg_nx),swg(1)
       complex*16 wg_dum(mg_nx)
       complex*16, allocatable, dimension(:) :: workr2_n

       integer nmap(matom)

       complex*16 sumdum(32,matom),sumdum2(32),sumdum3(32)
       complex*16 sumdumtmp(32,matom)
       complex*16 y,s,cc,s2
************************************************
****  extra memory for ilocal=2  !!!
*************************************************

c      real*8 xatom(3,matom)
       integer isNLa(9,matom),ityatom(matom),ipsp_type(mtype)
       complex*16 cy

       real*8 occ_t(mtype)
       integer iiatom(mtype),icore(mtype),numref(matom)
       real*8 Dij0(32,32,mtype),Qij(32,32,mtype)

*************************************************
       common /comisNLa/isNLa,Dij0,Qij,ipsp_all,ipsp_type
       common /comnmap/nmap
       common /comNL2/occ_t,iiatom,icore,numref,ityatom

       ng_n=ngtotnod(inode,kpt)

       call d3fft_comp(wg,workr_n,-1,kpt)

       if(ilocal.eq.2) then
       call nonlocal_realsp()
       endif

       if(ilocal.ne.2) then
       do i=1,nr_n
       workr_n(i)=dble(vr(i))*workr_n(i)
       enddo
       endif

       call d3fft_comp(wgh,workr_n,1,kpt)

       do i=1,ng_n
       wgh(i)=wgh(i)+gkk_n(i,kpt)*wg(i)
       enddo

       if(ilocal.eq.3) then
       call nonlocal_qsp()
       endif

       return

       contains
cccccccccccccccccccccccccccccccc

       subroutine nonlocal_realsp()
       implicit double precision (a-h,o-z)
       complex*16 y,cc1,cc0
       real*8 y_tmp1(10000),y_tmp2(10000)
       real*8 y_tmp31(10000),y_tmp32(10000)
       real*8 sumy1(32),sumy2(32)
       real*8 sumy31(32),sumy32(32)

       cc1=dcmplx(1.d0,0.d0)
       cc0=dcmplx(0.d0,0.d0)

       sumdum = dcmplx(0.d0,0.d0)

       ico1=0
       ico2=0
       do ia=1,natom
        nref=numref(ia)

cccccccccccccccccccccccccc
c	do i=1,nmap(ia)
c         ico1=ico1+1
c         y=dconjg(workr_n(indm(ico1))*cphase(ico1))
c          do jj = 1,nref
c          ico2=ico2+1
c           sumdum(jj,ia)=sumdum(jj,ia)+wmask(ico2)*y
c          enddo
c        enddo
cccccccccccccccccccccccccccccc
        if(nmap(ia).gt.10000) then
        write(6,*) "nmap.gt.10000, stop", nmap(ia),ia
        call  mpi_abort(MPI_COMM_WORLD,ierr)
        endif

	do i=1,nmap(ia)
        ico1=ico1+1
         y=dconjg(workr_n(indm(ico1))*cphase(ico1))
         y_tmp1(i)=dreal(y)
         y_tmp2(i)=dimag(y)
        enddo

ccccccccccccccccccccccccccccc
cccccccccc wmask is real*8 not complex*16 !
ccccccccccc maybe combine this to a matrix*matrix multiplication ?

       call dgemv('N',nref,nmap(ia),1.d0,wmask(ico2+1),nref,
     & y_tmp1,1,0.d0,sumy1,1)
       call dgemv('N',nref,nmap(ia),1.d0,wmask(ico2+1),nref,
     & y_tmp2,1,0.d0,sumy2,1)

          if(nmap(ia).gt.0) then  ! for nmap.eq.0, sumy1 not right, sumdum=0, initialized
        do jj=1,nref
        sumdum(jj,ia)=dcmplx(sumy1(jj),sumy2(jj))
        enddo
        ico2=ico2+nmap(ia)*nref
          endif
cccccccccccccccccccccccccccccccccccccccccccccc
       enddo   ! ia
ccccccccccccccc

       call mpi_barrier(MPI_COMM_K,ierr)

cccccccccccc most often, sumdum is much smaller than natom*32 !
       call mpi_allreduce(sumdum,sumdumtmp,natom*32,
     $     MPI_DOUBLE_COMPLEX,MPI_SUM, MPI_COMM_K,ierr)
       sumdum = sumdumtmp
ccccccccccccccccccccccccccccccccccccccccccccccccccc

       sumdum=sumdum*vol/(n1*n2*n3)
cccccccccccccccccccccccccccccccccccccccccc

       if(isij.eq.1.and.ipsp_all.eq.2) then
       allocate(workr2_n(mr_n))
       workr2_n=workr_n
       endif

       do i=1,nr_n
       workr_n(i)=dble(vr(i))*workr_n(i)
       enddo

       ico1=0
       ico2=0
       do ia=1,natom
        nref=numref(ia)
        iitype=ityatom(ia)

       do jj1=1,nref
        if(ipsp_type(iitype).eq.2) then
        cc=dcmplx(0.d0,0.d0)
        do jj2=1,nref
        cc=cc+Dij(jj2,jj1,ia,iislda)*sumdum(jj2,ia)
        enddo
        sumdum2(jj1)=dconjg(cc)
        else
        sumdum2(jj1)=Dij(jj1,jj1,ia,iislda)*
     &                    dconjg(sumdum(jj1,ia))
        endif

        if(isij.eq.1.and.ipsp_type(iitype).eq.2) then
        cc=cmplx(0.d0,0.d0)
        do jj2=1,nref
        cc=cc+Qij(jj2,jj1,iitype)*sumdum(jj2,ia)
        enddo
        sumdum3(jj1)=dconjg(cc)
        endif
       enddo   ! jj1=1,nref

cccccccccccc
c       if(isij.eq.1.and.ipsp_type(iitype).eq.2) then
c         do i=1,nmap(ia)
c         ico1=ico1+1
c         s=dcmplx(0.d0,0.d0)
c         s2=dcmplx(0.d0,0.d0)
c         do jj = 1,nref
c         ico2=ico2+1
c         s=s+sumdum2(jj)*wmask(ico2)
c         s2=s2+sumdum3(jj)*wmask(ico2)
c         enddo

c         workr_n(indm(ico1))=workr_n(indm(ico1))+
c     &         s*dconjg(cphase(ico1))
c         workr2_n(indm(ico1))=workr2_n(indm(ico1))+
c     &         s2*dconjg(cphase(ico1))
c         enddo
c       else
cccccccccccccccccccccccccccccccccccc
c         do i=1,nmap(ia)
c         ico1=ico1+1
c         s=dcmplx(0.d0,0.d0)
c         do jj = 1,nref
c         ico2=ico2+1
c         s=s+sumdum2(jj)*wmask(ico2)
c         enddo
c         workr_n(indm(ico1))=workr_n(indm(ico1))+
c     &            s*dconjg(cphase(ico1))
c         enddo    ! i=1,nmap
ccccccccccccccccccccccccccccccccccccccccccccccccc
c       endif

       if(isij.eq.1.and.ipsp_type(iitype).eq.2) then

       do jj=1,nref
       sumy1(jj)=dreal(sumdum2(jj))
       sumy2(jj)=dimag(sumdum2(jj))
       sumy31(jj)=dreal(sumdum3(jj))
       sumy32(jj)=dimag(sumdum3(jj))
       enddo
cccccccccccccc maybe we should really use matrix*matrix multiplication
       call dgemv('T',nref,nmap(ia),1.d0,wmask(ico2+1),nref,
     & sumy1,1,0.d0,y_tmp1,1)
       call dgemv('T',nref,nmap(ia),1.d0,wmask(ico2+1),nref,
     & sumy2,1,0.d0,y_tmp2,1)
       call dgemv('T',nref,nmap(ia),1.d0,wmask(ico2+1),nref,
     & sumy31,1,0.d0,y_tmp31,1)
       call dgemv('T',nref,nmap(ia),1.d0,wmask(ico2+1),nref,
     & sumy32,1,0.d0,y_tmp32,1)
        ico2=ico2+nmap(ia)*nref
       do i=1,nmap(ia)
       ico1=ico1+1
       workr_n(indm(ico1))=workr_n(indm(ico1))+
     &       dcmplx(y_tmp1(i),y_tmp2(i))*dconjg(cphase(ico1))
       workr2_n(indm(ico1))=workr2_n(indm(ico1))+
     &       dcmplx(y_tmp31(i),y_tmp32(i))*dconjg(cphase(ico1))
        enddo

       else

       do jj=1,nref
       sumy1(jj)=dreal(sumdum2(jj))
       sumy2(jj)=dimag(sumdum2(jj))
       enddo

       call dgemv('T',nref,nmap(ia),1.d0,wmask(ico2+1),nref,
     & sumy1,1,0.d0,y_tmp1,1)
       call dgemv('T',nref,nmap(ia),1.d0,wmask(ico2+1),nref,
     & sumy2,1,0.d0,y_tmp2,1)
        ico2=ico2+nmap(ia)*nref
       do i=1,nmap(ia)
       ico1=ico1+1
       workr_n(indm(ico1))=workr_n(indm(ico1))+
     &       dcmplx(y_tmp1(i),y_tmp2(i))*dconjg(cphase(ico1))
        enddo
       endif

cccccccccccccccccccccccccccc

       enddo      ! ia=1,natom

       if(isij.eq.1.and.ipsp_all.eq.2) then
       call d3fft_comp(swg,workr2_n,1,kpt)
       deallocate(workr2_n)
       endif

       return
       end subroutine nonlocal_realsp

cccccccccccccccccccccccccccccccccccccc
cccccccccccccccccccccccccccccccccccccc
cccccccccccccccccccccccccccccccccccccc

       subroutine nonlocal_qsp()
       implicit double precision (a-h,o-z)
       complex*16 cc1,cc0,sumy(32)
       cc1=dcmplx(1.d0,0.d0)
       cc0=dcmplx(0.d0,0.d0)

       sumdum = dcmplx(0.d0,0.d0)

       do ia=1,natom

        nref=numref(ia)
        iref_start2=iref_start(ia)

cccccccccccccccccccccccccccccccccccccccc
c        do jj = 1,nref
c        iref=iref_start2+jj
c          do i=1,ng_n
c          sumdum(jj,ia) = sumdum(jj,ia)+wqmask(i,iref)*
c     &                        dconjg(wg(i))  ! fetch two data. wqmask,wg, instead of one (if we switch (i,iref)).
c
c          enddo
c        enddo
cccccccccccccccccccccccccccccccccccccccc
       call zgemv('C',ng_n,nref,cc1,wqmask(1,iref_start2+1),
     & mg_nx,wg,1,cc0,sumy,1)

       if(ng_n.gt.0) then
       do jj=1,nref
       sumdum(jj,ia)=dconjg(sumy(jj))
       enddo
       endif

       enddo      ! ia
cccccccccccccccccccccccccccccccccc

       call mpi_allreduce(sumdum,sumdumtmp,natom*32,
     $     MPI_DOUBLE_COMPLEX,MPI_SUM, MPI_COMM_K,ierr)
       sumdum = sumdumtmp

       sumdum=vol*sumdum

cccccccccccccccccc

       if(isij.eq.1.and.ipsp_all.eq.2) then
       do i=1,ng_n
       swg(i)=wg(i)
       enddo
       endif

       do ia=1,natom
        nref=numref(ia)
        iref_start2=iref_start(ia)
        iitype=ityatom(ia)

       do jj1=1,nref
        if(ipsp_type(iitype).eq.2) then
        cc=0.d0
        do jj2=1,nref
        cc=cc+Dij(jj2,jj1,ia,iislda)*sumdum(jj2,ia)
        enddo
        sumdum2(jj1)=dconjg(cc)
        else
        sumdum2(jj1)=Dij(jj1,jj1,ia,iislda)*
     &                    dconjg(sumdum(jj1,ia))
        endif

        if(isij.eq.1.and.ipsp_type(iitype).eq.2) then
        cc=0.d0
        do jj2=1,nref
        cc=cc+Qij(jj2,jj1,iitype)*sumdum(jj2,ia)
        enddo
        sumdum3(jj1)=dconjg(cc)
        endif
       enddo

ccccccccccccccccccccccccccccccccccccc
c        do jj = 1,nref
c        iref=iref_start2+jj
c          if(isij.eq.1.and.ipsp_type(iitype).eq.2) then
c           do i=1,ng_n
c           wgh(i)=wgh(i)+sumdum2(jj)*wqmask(i,iref)
c           swg(i)=swg(i)+sumdum3(jj)*wqmask(i,iref)
c           enddo
c          else
c           do i=1,ng_n
c           wgh(i)=wgh(i)+sumdum2(jj)*wqmask(i,iref)
c           enddo
c          endif
c        enddo
ccccccccccccccccccccccccccccccccccccc

       if(isij.eq.1.and.ipsp_type(iitype).eq.2) then
       call zgemv('N',ng_n,nref,cc1,wqmask(1,iref_start2+1),
     & mg_nx,sumdum2,1,cc1,wgh,1)
       call zgemv('N',ng_n,nref,cc1,wqmask(1,iref_start2+1),
     & mg_nx,sumdum3,1,cc1,swg,1)
       else
       call zgemv('N',ng_n,nref,cc1,wqmask(1,iref_start2+1),
     & mg_nx,sumdum2,1,cc1,wgh,1)
       endif

       enddo     !  do ia

        return

       end subroutine nonlocal_qsp
ccccccccccccccccccccccccc
       end

ext: f

max_stars_repo_name: qsnake/petot

max_issues_repo_name: qsnake/petot

max_forks_repo_name: qsnake/petot


text:
C--- Implementation of arXiv:0906.0008v1, Eqs. (A.5), (A.6) and (A.7)
c--- with factor of i removed

      double complex function A0phiAQggmppm(j1,j2,j3,j4,za,zb)
      implicit none
c--- (A.5) second line
c----with factor of i removed
      include 'constants.f'
      include 'zprods_decl.f'
      integer j1,j2,j3,j4

      A0phiAQggmppm=-za(j1,j4)**2*za(j2,j4)
     .                 /(za(j1,j2)*za(j2,j3)*za(j3,j4))

      return
      end

      double complex function A0phiAQggmpmp(j1,j2,j3,j4,za,zb)
      implicit none
c--- (A.5) third line
c----with factor of i removed
      include 'constants.f'
      include 'zprods_decl.f'
      integer j1,j2,j3,j4

      A0phiAQggmpmp=za(j1,j3)**3/(za(j1,j2)*za(j3,j4)*za(j4,j1))

      return
      end

      double complex function A0phidAQggmppm(j1,j2,j3,j4,za,zb)
      implicit none
c--- (A.5) fifth line
c----with factor of i removed
      include 'constants.f'
      include 'zprods_decl.f'
      integer j1,j2,j3,j4

      A0phidAQggmppm=-zb(j2,j3)**2*zb(j1,j3)
     .                   /(zb(j1,j2)*zb(j3,j4)*zb(j4,j1))

      return
      end

      double complex function A0phidAQggmpmp(j1,j2,j3,j4,za,zb)
      implicit none
c--- (A.5) sixth line
c----with factor of i removed
      include 'constants.f'
      include 'zprods_decl.f'
      integer j1,j2,j3,j4

      A0phidAQggmpmp=zb(j2,j4)**3
     .                  /(zb(j1,j2)*zb(j2,j3)*zb(j3,j4))

      return
      end

      double complex function A0phiAQggmpmm(j1,j2,j3,j4,za,zb)
      implicit none
c--- (A.6)
c----with factor of i removed
      include 'constants.f'
      include 'zprods_decl.f'
      include 'sprods_com.f'
      integer j1,j2,j3,j4
      double complex zab2
      double precision s3
      s3(j1,j2,j3)=s(j1,j2)+s(j2,j3)+s(j3,j1)
      zab2(j1,j2,j3,j4)=za(j1,j2)*zb(j2,j4)+za(j1,j3)*zb(j3,j4)

      A0phiAQggmpmm=-zab2(j3,j1,j4,j2)**2*za(j4,j1)
     .               /zb(j2,j4)/s3(j4,j1,j2)*(1d0/s(j1,j2)+1d0/s(j4,j1))
     .              -zab2(j4,j1,j3,j2)**2*za(j1,j3)
     .               /(zb(j2,j3)*s(j1,j2)*s3(j1,j2,j3))
     .              +zab2(j1,j3,j4,j2)**2
     .               /(za(j1,j2)*zb(j2,j4)*zb(j2,j3)*zb(j3,j4))

      return
      end

      double complex function A0phidAQggmppp(j1,j2,j3,j4,za,zb)
      implicit none
c--- (A.7)
c----with factor of i removed
      include 'constants.f'
      include 'zprods_decl.f'
      include 'sprods_com.f'
      integer j1,j2,j3,j4
      double complex zab2
      double precision s3
      s3(j1,j2,j3)=s(j1,j2)+s(j2,j3)+s(j3,j1)
      zab2(j1,j2,j3,j4)=za(j1,j2)*zb(j2,j4)+za(j1,j3)*zb(j3,j4)

      A0phidAQggmppp=-zab2(j1,j2,j3,j4)**2*zb(j2,j3)
     .               /za(j1,j3)/s3(j1,j2,j3)*(1d0/s(j1,j2)+1d0/s(j2,j3))
     .              +zab2(j1,j2,j4,j3)**2*zb(j2,j4)
     .               /(za(j1,j4)*s(j1,j2)*s3(j4,j1,j2))
     .              -zab2(j1,j3,j4,j2)**2
     .               /(zb(j1,j2)*za(j1,j3)*za(j1,j4)*za(j3,j4))

      return
      end

max_stars_repo_name: tmartini/JHUGen

max_issues_repo_name: tmartini/JHUGen

max_forks_repo_name: tmartini/JHUGen


text:
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C     *                                                               *
C     *                  copyright (c) 2011 by UCAR                   *
C     *                                                               *
C     *       University Corporation for Atmospheric Research         *
C     *                                                               *
C     *                      all rights reserved                      *
C     *                                                               *
C     *                     FFTPACK  version 5.1                      *
C     *                                                               *
C     *                 A Fortran Package of Fast Fourier             *
C     *                                                               *
C     *                Subroutines and Example Programs               *
C     *                                                               *
C     *                             by                                *
C     *                                                               *
C     *               Paul Swarztrauber and Dick Valent               *
C     *                                                               *
C     *                             of                                *
C     *                                                               *
C     *         the National Center for Atmospheric Research          *
C     *                                                               *
C     *                Boulder, Colorado  (80307)  U.S.A.             *
C     *                                                               *
C     *                   which is sponsored by                       *
C     *                                                               *
C     *              the National Science Foundation                  *
C     *                                                               *
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
      SUBROUTINE R1F2KB (IDO,L1,CC,IN1,CH,IN2,WA1)
      REAL       CC(IN1,IDO,2,L1), CH(IN2,IDO,L1,2), WA1(IDO)
C
      DO 101 K=1,L1
         CH(1,1,K,1) = CC(1,1,1,K)+CC(1,IDO,2,K)
         CH(1,1,K,2) = CC(1,1,1,K)-CC(1,IDO,2,K)
 101  CONTINUE
      IF (IDO-2) 107,105,102
 102  IDP2 = IDO+2
      DO 104 K=1,L1
         DO 103 I=3,IDO,2
            IC = IDP2-I

            CH(1,I-1,K,1) = CC(1,I-1,1,K)+CC(1,IC-1,2,K)
            CH(1,I,K,1) = CC(1,I,1,K)-CC(1,IC,2,K)

            CH(1,I-1,K,2) = WA1(I-2)*(CC(1,I-1,1,K)-CC(1,IC-1,2,K))
     1           -WA1(I-1)*(CC(1,I,1,K)+CC(1,IC,2,K))
            CH(1,I,K,2) = WA1(I-2)*(CC(1,I,1,K)+CC(1,IC,2,K))+WA1(I-1)
     1           *(CC(1,I-1,1,K)-CC(1,IC-1,2,K))

 103     CONTINUE
 104  CONTINUE
      IF (MOD(IDO,2) .EQ. 1) RETURN
 105  DO 106 K=1,L1
         CH(1,IDO,K,1) = CC(1,IDO,1,K)+CC(1,IDO,1,K)
         CH(1,IDO,K,2) = -(CC(1,1,2,K)+CC(1,1,2,K))
 106  CONTINUE
 107  RETURN
      END

max_stars_repo_name: bgin/MissileSimulation

max_issues_repo_name: bgin/MissileSimulation

max_forks_repo_name: bgin/MissileSimulation


text:
As students and professors search for real world communities to study, West Sacramento has frequently hosted UCDs academic pursuits. Posted here, we provide this research for members of the community to use as they see fit, to educate themselves about West Sacramento and to inform their decisions about the future of the city.

Community Development Graduate Student Research

In 2005, two members of the West Sacramento city council, current Councilmember Oscar Villegas and past member Carolyn Pierson requested that the Community Development Graduate Group do an interactive study of the Bryte and Broderick neighborhoods with the intention of promoting healthy and safe activities for youth in these neighborhoods. Under the leadership of Professor Ted Bradshaw, the Community Development graduate group committed to studying the Bryte and Broderick neighborhoods for 3 years, through the capstone course, CRD 440: Professional Skills in Community Development, typically taken by 2nd year graduate students. The following materials are the results of this ongoing relationship between UC Davis and the neighborhoods of Bryte and Broderick.

2006
During the Winter Quarter of 2006, CRD 440 students acted as a virtual consulting firm, creating an assetsbased community assessment of the Bryte and Broderick neighborhoods.  The thirteen graduate students interviewed over 100 community members, created an inventory of community services, and compiled and analyzed economic and demographic data.  The resulting report and executive summary formed a basis for all future 440 work in West Sacramento, and included concrete recommendations for city officials, residents, and other concerned community members, as well as appendixes on model city and community programs in similar neighborhoods through the country.

Report and Executive Summary
Executive Summary of 2006 report File(CRD440_B_B_summary2006.doc.pdf)
2006 Report on Bryte and Broderick: Enhancing Community Planning Capacity in West Sacramento File(CRD 440 Report  2006.pdf)

2007
During Winter Quarter of 2007, CRD 440 students worked with the West Sacramento Youth Resource Coalition and REACH to analyze data from extensive interviews in West Sacramento, and with a youth group called the Sac Town Heroes to map their perceptions of safe and unsafe places in particularly the Bryte and Broderick neighborhoods.

These three months of work by almost twenty students were incorporated into the REACH Coalitions report to the Sierra Health Foundation, as well as 3 GIS maps. The photographic assessment of their neighborhoods by the Sac Town Heroes, with input from other youth, yielded a map of these findings for Bryte and Broderick. In addition, a map was created of the services listed in the previous class services guide; and a final map makes recommendations for neighborhood development based on the two years of observation.

Papers
The report from the REACH Coalition, authored by the West Sacramento Youth Resource Coalition, with contributions from the 440 students, is entitled: West Sacramento Youth: A community profile File(Community_Profile_W_Sac.pdf)
The 440 students experience of working with the West Sacramento Youth Resource Coalition was documented in their final paper: File(CRD440_WSYRC_FinalPaper.pdf)
The community mapping research is summarized in the report: Defining Space in the Bryte and Broderick Neighborhoods of West Sacramento: File(CRD_440_Mapping_FinalPaper.pdf)
The community services inventory from the previous year was updated.  The 2007 version is: File(UpdatedServicesInventory.xls)

Maps

The methods used to create all the above GIS maps are documented here: File(Methods_for_GIS_Map.pdf)

For more information, contact Mailto(braustin AT ucdavis DOT edu, Bernadette Austin).

Additionally, several Community Development graduate students have done independent research projects in West Sacramento, for coursework or their masters thesis work.

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search