xy_av_den.f90 1.7 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68
      MODULE m_xyavden
      CONTAINS
      SUBROUTINE xy_av_den(&
     &                    stars,vacuum,cell,psq,rht)

      USE m_types
      USE m_cfft
      IMPLICIT NONE
      TYPE(t_vacuum),INTENT(IN)   :: vacuum
      TYPE(t_stars),INTENT(IN)   :: stars
      TYPE(t_cell),INTENT(IN)   :: cell
      REAL,    INTENT(IN) :: rht(vacuum%nmzd,2)
      COMPLEX, INTENT(IN) :: psq(stars%n3d)

      INTEGER  ivfft,i,j,k
      REAL     ani,z
      REAL,    ALLOCATABLE :: af1(:),bf1(:)

      ivfft =  3*stars%k3d
      ALLOCATE (af1(ivfft),bf1(ivfft))

      af1(:) = 0.0 ; bf1(:) = 0.0
      DO i = 1, stars%ng3
        IF (stars%ig2(i) == 1) THEN
          k = stars%kv3(3,i)
          IF ( k < 0 ) THEN
            k = ivfft + k + 1 
          ELSE
            k = k + 1
          ENDIF
          af1(k) = real(psq(i))
          bf1(k) = aimag(psq(i))
        ENDIF
      ENDDO

      CALL cfft(af1,bf1,ivfft,ivfft,ivfft,+1)

      OPEN(77,file='qws',status='unknown')
      j = 1
      k = 3 - 2*j
      DO i = vacuum%nmz,1,-1
        z = (vacuum%dvac/2 + (i-1)*vacuum%delz) * k 
        WRITE(77,'(2f20.10)') z,rht(i,j)*cell%area
      ENDDO
      ani = 1.0/real(ivfft)
      j = 0
      DO i = 0,ivfft - 1
        j = j + 1
        z = cell%amat(3,3)*i*ani
        IF (z > cell%amat(3,3)/2) z = z - cell%amat(3,3)
        IF ( abs(z) < vacuum%dvac/2 ) THEN
          WRITE(77,'(2f20.10)') z,af1(j)*cell%area
        ENDIF
      ENDDO
      j = 1
      k = 3 - 2*j
      DO i = 1, vacuum%nmz
        z = (vacuum%dvac/2 + (i-1)*vacuum%delz) * k 
        WRITE(77,'(2f20.10)') z,rht(i,j)*cell%area
      ENDDO
      
      CLOSE(77)
      DEALLOCATE (af1,bf1)
      STOP

      END SUBROUTINE xy_av_den
      END MODULE m_xyavden